]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/phojet1.12-35c3.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix in procedure for vertex recalculation
[u/mrichter/AliRoot.git] / DPMJET / phojet1.12-35c3.f
CommitLineData
9aaba0d6 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
34C interface to PYTHIA 6.1 (or higher)
35C for usage in DPMJET 3.x (Lund common block dimensions increased)
36C
37C***********************************************************************
38C
39C
40C List of subroutines and functions
41C ---------------------------------
42C
43C
44C main event simulation routines
45C
46C PHO_EVENT
47C PHO_PARTON
48C PHO_POSPOM
49C
50C PHO_STDPAR
51C PHO_POMSCA
52C
53C
54C user steering interface
55C
56C PHO_SETMDL
57C PHO_PRESEL
58C
59C
60C experimental setup / photon flux calculation
61C
62C PHO_FIXLAB
63C PHO_FIXCOL
64C PHO_GPHERA
65C PHO_GGEPEM
66C PHO_WGEPEM
67C PHO_GGBLSR
68C PHO_GGBEAM
69C PHO_GGHIOF
70C PHO_GGHIOG
71C PHO_GGFLCL
72C PHO_GGFLCR
73C PHO_GGFAUX
74C PHO_GGFNUC
75C PHO_GHHIOF
76C PHO_GHHIAS
77C
78C
79C initialization
80C
81C PHO_INIT
82C PHO_DATINI
83C PHO_PARDAT
84C PHO_MCINI
85C
86C PHO_EVEINI
87C
88C PHO_HARINI
89C PHO_FRAINI
90C
91C PHO_FITPAR
92C
93C
94C cross section calculation
95C
96C PHO_CSINT
97C
98C PHO_XSECT
99C PHO_BORNCS
100C PHO_HARXTO
101C
102C PHO_DSIGDT
103C
104C PHO_TRIREG
105C PHO_LOOREG
106C PHO_TRXPOM
107C
108C PHO_EIKON
109C PHO_CHAN2A
110C
111C PHO_SCALES
112C
113C
114C multiple interaction structure
115C
116C PHO_IMPAMP
117C PHO_PRBDIS
118C PHO_SAMPRO
119C PHO_SAMPRB
120C
121C
122C hadron / photon remnant treatment, soft x selection
123C
124C PHO_HARREM
125C PHO_PARREM
126C
127C PHO_HADSP2
128C PHO_HADSP3
129C PHO_SOFTXX
130C PHO_SELSXR
131C PHO_SELSX2
132C PHO_SELSXS
133C PHO_SELSXI
134C
135C PHO_VALFLA
136C PHO_REGFLA
137C PHO_SEAFLA
138C PHO_FLAUX
139C PHO_BETAF
140C IPHO_DIQU
141C
142C
143C primordial kt and soft parton pt
144C
145C PHO_PRIMKT
146C PHO_PARTPT
147C PHO_SOFTPT
148C PHO_SELPT
149C
150C PHO_CONN0
151C PHO_CONN1
152C
153C
154C simulation of hard scattering, initial state radiation
155C
156C PHO_HARCOL
157C PHO_SELCOL
158C PHO_HARCOR
159C
160C PHO_HARDIR
161C PHO_HARX12
162C PHO_HARDX1
163C PHO_HARKIN
164C PHO_HARWGH
165C PHO_HARSCA
166C PHO_HARFAC
167C PHO_HARWGX
168C PHO_HARWGI
169C PHO_HARINT
170C PHO_HARMCI
171C
172C PHO_HARXR3
173C PHO_HARXR2
174C PHO_HARXD2
175C PHO_HARXPT
176C PHO_HARISR
177C PHO_HARZSP
178C
179C PHO_PTCUT
180C PHO_ALPHAE
181C PHO_ALPHAS
182C
183C
184C diffraction dissociation
185C
186C PHO_DIFDIS
187C PHO_DIFPRO
188C PHO_DIFPAR
189C PHO_QELAST
190C PHO_CDIFF
191C PHO_DFWRAP
192C
193C PHO_SAMASS
194C PHO_DSIGDM
195C PHO_DFMASS
196C
197C PHO_SDECAY
198C PHO_SDECY2
199C PHO_SDECY3
200C
201C PHO_DIFSLP
202C PHO_DIFKIN
203C PHO_VECRES
204C PHO_DIFRES
205C
206C PHO_REGPAR
207C
208C PHO_PECMS
209C PHO_SETPAR
210C
211C
212C fragmentation, treatment of low-mass strings
213C
214C PHO_STRING
215C PHO_STRFRA
216C
217C PHO_ID2STR
218C PHO_MCHECK
219C PHO_POMCOR
220C PHO_MASCOR
221C PHO_PARCOR
222C
223C PHO_GLU2QU
224C PHO_GLUSPL
225C
226C PHO_DQMASS
227C PHO_BAMASS
228C PHO_MEMASS
229C
230C
231C particle code tables, particle numbering conversion
232C
233C PHO_PNAME
234C PHO_PMASS
235C IPHO_CHR3
236C IPHO_BAR3
237C
238C IPHO_ANTI
239C
240C IPHO_PDG2ID
241C IPHO_ID2PDG
242C IPHO_LU2PDG
243C IPHO_PDG2LU
244C
245C IPHO_CNV1
246C PHO_HACODE
247C
248C
249C
250C Lorentz transformations, rotations and mass adjustment
251C
252C PHO_ALTRA
253C PHO_LTRANS
254C PHO_TRANS
255C PHO_TRANI
256C
257C PHO_MKSLTR
258C PHO_GETLTR
259C
260C PHO_LTRHEP
261C
262C PHO_MSHELL
263C PHO_MASSAD
264C
265C
266C program debugging and internal cross-checks
267C
268C PHO_PREVNT
269C PHO_PRSTRG
270C PHO_CHECK
271C
272C PHO_TRACE
273C
274C PHO_REJSTA
275C
276C PHO_ABORT
277C
278C
279C cross section fitting
280C
281C PHO_FITMAI
282C PHO_FITINP
283C PHO_FITDAT
284C PHO_FITOUT
285C PHO_FITAMP
286C PHO_FITTST
287C PHO_FITMSQ
288C PHO_FITVD1
289C PHO_FITCN1
290C PHO_FITINI
291C
292C
293C cross section parametrizations
294C
295C PHO_HADCSL
296C PHO_ALLM97
297C PHO_CSDIFF
298C
299C
300C random numbers
301C
302C DPMJET random number generator DT_RNDM used
303C
304C PHO_SFECFE
305C PHO_RNDBET
306C PHO_RNDGAM
307C
308C
309C auxiliary routines / numerical methods
310C
311C PHO_GAUSET
312C PHO_GAUDAT
313C
314C pho_samp1d
315C
316C PHO_DZEROX
317C PHO_EXPINT
318C PHO_BESSJ0
319C PHO_BESSI0
320C pho_ExpBessI0
321C PHO_BESSI1
322C PHO_BESSK0
323C PHO_BESSK1
324C
325C PHO_XLAM
326C
327C PHO_SWAPD
328C PHO_SWAPI
329C
330C
331C parton density parametrization management / interface
332C
333C PHO_PDF
334C
335C PHO_SETPDF
336C PHO_GETPDF
337C PHO_ACTPDF
338C
339C PHO_QPMPDF
340C
341C PHO_PDFTST
342C
343C
344C parton density parametrizations from other authors
345C
346C PHO_DOR98LO
347C PHO_DOR98SC
348C PHO_DOR94LO
349C PHO_DOR94HO
350C PHO_DOR94DI
351C PHO_DOR92LO
352C PHO_DOR92HO
353C PHO_DORPLO
354C PHO_DORPHO
355C PHO_DORGLO
356C PHO_DORGHO
357C PHO_DORGH0
358C PHO_DOR94FV
359C PHO_DOR94FW
360C PHO_DOR94FS
361C PHO_DOR92FV
362C PHO_DOR92FW
363C PHO_DOR92FS
364C PHO_DORFVP
365C PHO_DORFGP
366C PHO_DORFQP
367C PHO_DORGF
368C PHO_DORGFS
369C PHO_grsf1
370C PHO_grsf2
371C
372C PHO_CKMTPA
373C PHO_CKMTPD
374C PHO_CKMTPO
375C PHO_CKMTFV
376C
377C PHO_DBFINT
378C
379C PHO_SASGAM
380C PHO_SASVMD
381C PHO_SASANO
382C PHO_SASBEH
383C PHO_SASDIR
384C
385C PHO_PHGAL
386C PHVAL
387C
388C
389C***********************************************************************
390
391*$ CREATE PHO_INIT.FOR
392*COPY PHO_INIT
393CDECK ID>, PHO_INIT
394 SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
395C***********************************************************************
396C
397C main subroutine to configure and manage PHOJET calculations
398C
399C input: LINP input unit to read from
400C -1 to skip reading of input file
401C LOUT output unit to write to
402C
403C output: IREJ 0 success
404C 1 failure
405C
406C***********************************************************************
407 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
408 SAVE
409
410C input/output channels
411 INTEGER LI,LO
412 COMMON /POINOU/ LI,LO
413C event debugging information
414 INTEGER NMAXD
415 PARAMETER (NMAXD=100)
416 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
417 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
418 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
419 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
420C model switches and parameters
421 CHARACTER*8 MDLNA
422 INTEGER ISWMDL,IPAMDL
423 DOUBLE PRECISION PARMDL
424 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
425C general process information
426 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
427 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
428
429C global event kinematics and particle IDs
430 INTEGER IFPAP,IFPAB
431 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
432 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
433C nucleon-nucleus / nucleus-nucleus interface to DPMJET
434 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
435 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
436 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
437 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
438C integration precision for hard cross sections (obsolete)
439 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
440 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
441C some hadron information, will be deleted in future versions
442 INTEGER NFS
443 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
444 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
445C obsolete cut-off information
446 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
447 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
448C photon flux kinematics and cuts
449 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
450 & YMIN1,YMAX1,YMIN2,YMAX2,
451 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
452 & THMIN1,THMAX1,THMIN2,THMAX2
453 INTEGER ITAG1,ITAG2
454 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
455 & YMIN1,YMAX1,YMIN2,YMAX2,
456 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
457 & THMIN1,THMAX1,THMIN2,THMAX2,
458 & ITAG1,ITAG2
459C cut probability distribution
460 INTEGER IEETA1,IIMAX,KKMAX
461 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
462 INTEGER IEEMAX,IMAX,KMAX
463 REAL PROB
464 DOUBLE PRECISION EPTAB
465 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
466 & IEEMAX,IMAX,KMAX
467C event weights and generated cross section
468 INTEGER IPOWGC,ISWCUT,IVWGHT
469 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
470 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
471 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
472C names of hard scattering processes
473 INTEGER Max_pro_1
474 PARAMETER ( Max_pro_1 = 16 )
475 CHARACTER*18 PROC
476 COMMON /POHPRO/ PROC(0:Max_pro_1)
477C hard cross sections and MC selection weights
478 INTEGER Max_pro_2
479 PARAMETER ( Max_pro_2 = 16 )
480 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
481 & MH_acc_1,MH_acc_2
482 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
483 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
484 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
485 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
486 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
487 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
488
489 INTEGER MSTU,MSTJ
490 DOUBLE PRECISION PARU,PARJ
491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
492 INTEGER KCHG
493 DOUBLE PRECISION PMAS,PARF,VCKM
494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
495 INTEGER MDCY,MDME,KFDP
496 DOUBLE PRECISION BRAT
bd378884 497 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 498
499 INTEGER PYCOMP
500
501 DIMENSION ITMP(0:11)
502 CHARACTER*10 CNAME
503 CHARACTER*70 NUMBER,FILENA
504
505 14 FORMAT(A10,A69)
506 15 FORMAT(A12)
507
508C define input/output units
509 IF(LINP.GE.0) THEN
510 LI = LINP
511 ELSE
512 LI = 5
513 ENDIF
514 LO = LOUT
515
516 IREJ = 0
517
518 WRITE(LO,*)
519 WRITE(LO,*) ' ==================================================='
520 WRITE(LO,*) ' '
521 WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
522 WRITE(LO,*) ' '
523 WRITE(LO,*) ' ==================================================='
524 WRITE(LO,*) ' Authors: Ralph Engel (FZ Karlsruhe)'
525 WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
526 WRITE(LO,*) ' Stefan Roesler (CERN)'
527 WRITE(LO,*) ' ---------------------------------------------------'
528 WRITE(LO,*) ' Manual, updates, and further information:'
529 WRITE(LO,*) ' http://www-ik.fzk.de/~engel/phojet.html'
530 WRITE(LO,*) ' ---------------------------------------------------'
531 WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
532 WRITE(LO,*) ' ralph.engel@fzk.de'
533 WRITE(LO,*) ' ==================================================='
534 WRITE(LO,*) ' $Date: 2000/06/25 21:59:19 $'
535 WRITE(LO,*) ' $Revision: 1.12.1.35 $'
536 WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
537 WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
538 WRITE(LO,*) ' ==================================================='
539 WRITE(LO,*)
540
541C standard initializations
542 CALL PHO_DATINI
543 CALL PHO_PARDAT
544 DUM = PHO_PMASS(0,-1)
545
546C initialize standard PDFs
547C proton
548 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
549 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
550C neutron
551 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
552 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
553C photon
554 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
555C pomeron
556 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
557C pions
558 CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
559 CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
560 CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
561C kaons
562 CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
563 CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
564 CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
565 CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
566
567C nothing to be done
568 IF(LINP.LT.0) RETURN
569
570C main loop to read input cards
571 1200 CONTINUE
572 READ(LINP,14,END=1300) CNAME,NUMBER
573 IF(CNAME.EQ.'ENDINPUT ') THEN
574 GOTO 1300
575 ELSE IF(CNAME.EQ.'STOP ') THEN
576 WRITE(LO,*) 'STOP'
577 STOP
578 ELSE IF(CNAME.EQ.'COMMENT ') THEN
579 WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
580 ELSE IF(CNAME(1:1).EQ.'*') THEN
581 WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
582 ELSE IF(CNAME.EQ.'PTCUT ') THEN
583 READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
584 WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
585 & PARMDL(38),PARMDL(39)
586 ELSE IF(CNAME.EQ.'PROCESS ') THEN
587 READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
588 WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
589 ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
590 READ(NUMBER,*) (ITMP(KK),KK=0,11)
591 WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
592 DO 112 KK=1,8
593 IPRON(KK,ITMP(0)) = ITMP(KK)
594 112 CONTINUE
595 ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
596 READ(NUMBER,*) IMPRO,IP,ION
597 WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
598 MH_pro_on(IMPRO,IP) = ION
599 ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
600 READ(NUMBER,*) IDPDG,PVIR
601 IHFLS(1) = 1
602 XPSUB = 1.D0
603 CALL PHO_SETPAR(1,IDPDG,0,PVIR)
604 WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
605 ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
606 READ(NUMBER,*) IDPDG,PVIR
607 IHFLS(2) = 1
608 XTSUB = 1.D0
609 CALL PHO_SETPAR(2,IDPDG,0,PVIR)
610 WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
611 ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
612 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
613 IHFLS(1) = IVAL
614 IHFLD(1,1) = IFL1
615 IHFLD(1,2) = IFL2
616 XPSUB = XSUB
617 PVIR = 0.D0
618 CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
619 WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
620 ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
621 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
622 IHFLS(2) = IVAL
623 IHFLD(2,1) = IFL1
624 IHFLD(2,2) = IFL2
625 XTSUB = XSUB
626 PVIR = 0.D0
627 CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
628 WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
629 ELSE IF(CNAME.EQ.'PDF ') THEN
630 READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
631 WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
632 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
633 ELSE IF(CNAME.EQ.'SETMODEL ') THEN
634 READ(NUMBER,*) I,IVAL
635 WRITE(LO,*) 'SETMODEL ',I,IVAL
636 CALL PHO_SETMDL(I,IVAL,1)
637 ELSE IF(CNAME.EQ.'SETPARAM ') THEN
638 READ(NUMBER,*) I,PARNEW
639 WRITE(LO,*) 'SETPARAM ',I,PARNEW
640 PARMDL(I) = PARNEW
641 ELSE IF(CNAME.EQ.'DEBUG ') THEN
642 READ(NUMBER,*) IDEBF,IDEBN,IDLEV
643 WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
644 CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
645 ELSE IF(CNAME.EQ.'TRACE ') THEN
646 READ(NUMBER,*) IDEBF,IDLEV
647 WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
648 IDEB(IDEBF) = IDLEV
649 ELSE IF(CNAME.EQ.'SETICUT ') THEN
650 READ(NUMBER,*) I,ICUT
651 WRITE(LO,*) 'SETICUT ',I,ICUT
652 ISWCUT(I) = ICUT
653 ELSE IF(CNAME.EQ.'SETFCUT ') THEN
654 READ(NUMBER,*) I,PARNEW
655 WRITE(LO,*) 'SETFCUT ',I,PARNEW
656 HSWCUT(I) = PARNEW
657 ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
658 READ(NUMBER,*) I,IVAL
659 WRITE(LO,*) 'LUND-MSTU ',I,IVAL
660 MSTU(I) = IVAL
661 ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
662 READ(NUMBER,*) I,IVAL
663 WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
664 MSTJ(I) = IVAL
665 ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
666 READ(NUMBER,*) I,EE
667 WRITE(LO,*) 'LUND-PARJ ',I,EE
668 PARJ(I) = REAL(EE)
669 ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
670 READ(NUMBER,*) I,EE
671 WRITE(LO,*) 'LUND-PARU ',I,EE
672 PARU(I) = REAL(EE)
673 ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
674 READ(NUMBER,*) ID,ION
675 WRITE(LO,*) 'LUND-DECAY ',ID,ION
676 KC=PYCOMP(ID)
677 MDCY(KC,1) = ION
678 ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
679 READ(NUMBER,*) PSOMIN
680 WRITE(LO,*) 'PSOFTMIN ',PSOMIN
681 ELSE IF(CNAME.EQ.'INTPREC ') THEN
682 READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
683 WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
684
685C PDF test utility
686 ELSE IF(CNAME.EQ.'PDFTEST ') THEN
687 READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
688 PVIRT2 = ABS(PVIRT2)
689 WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
690 CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
691
692C mass cut on gamma-gamma or gamma-hadron system
693 ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
694 READ(NUMBER,*) ECMIN,ECMAX
695 WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
696
697C beam lepton (anti-)tagging system
698 ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
699 READ(NUMBER,*) ITAG1,ITAG2
700 WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
701 ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
702 READ(NUMBER,*)
703 & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
704 WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
705 & Q2MIN1,Q2MAX1,THMIN1,THMAX1
706 ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
707 READ(NUMBER,*)
708 & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
709 WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
710 & Q2MIN2,Q2MAX2,THMIN2,THMAX2
711
712C sampling of gamma-p events in ep (HERA)
713 ELSE IF( (CNAME.EQ.'WW-HERA ')
714 & .OR.(CNAME.EQ.'GP-HERA ')) THEN
715 READ(NUMBER,*) EE1,EE2,NEV
716 WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
717 IF(YMAX2.LT.0.D0) THEN
718 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
719 ELSE
720 CALL PHO_GPHERA(NEV,EE1,EE2)
721 KEVENT = 0
722 ENDIF
723
724C sampling of gamma-gamma events in e+e- (LEP)
725 ELSE IF( (CNAME.EQ.'GG-EPEM ')
726 & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
727 READ(NUMBER,*) EE1,EE2,NEV
728 WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
729 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
730 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
731 ELSE
732 CALL PHO_GGEPEM(-1,EE1,EE2)
733 CALL PHO_GGEPEM(NEV,EE1,EE2)
734 CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
735 KEVENT = 0
736 ENDIF
737
738C sampling of gamma-gamma in heavy-ion collisions
739 ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
740 READ(NUMBER,*) EE,NA,NZ,NEV
741 WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
742 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
743 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
744 ELSE
745 CALL PHO_GGHIOF(NEV,EE,NA,NZ)
746 KEVENT = 0
747 ENDIF
748 ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
749 READ(NUMBER,*) EE,NA,NZ,NEV
750 WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
751 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
752 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
753 ELSE
754 CALL PHO_GGHIOG(NEV,EE,NA,NZ)
755 KEVENT = 0
756 ENDIF
757
758C sampling of gamma-hadron events in heavy ion collisions
759 ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
760 READ(NUMBER,*) EE,NA,NZ,NEV
761 WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
762 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
763 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
764 ELSE
765 CALL PHO_GHHIOF(NEV,EE,NA,NZ)
766 KEVENT = 0
767 ENDIF
768
769C sampling of hadron-gamma events in hadron - heavy ion collisions
770 ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
771 READ(NUMBER,*) EP,EE,NA,NZ,NEV
772 WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
773 IF(YMAX2.LT.0.D0) THEN
774 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
775 ELSE
776 CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
777 KEVENT = 0
778 ENDIF
779
780C sampling of photoproduction events e+e-, backscattered laser
781 ELSE IF(CNAME.EQ.'BLASER ') THEN
782 READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
783 WRITE(LO,*) 'BLASER ',EE1,EE2,
784 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
785 CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
786 KEVENT = 0
787
788C sampling of photoproduction events beamstrahlung
789 ELSE IF(CNAME.EQ.'BEAMST ') THEN
790 READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
791 WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
792 IF(YMAX1.LT.0.D0) THEN
793 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
794 ELSE
795 CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
796 KEVENT = 0
797 ENDIF
798
799C fixed-energy events in LAB system of particle 2
800 ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
801 READ(NUMBER,*) PLAB,NEV
802 WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
803 CALL PHO_FIXLAB(PLAB,NEV)
804 KEVENT = 0
805
806C fixed-energy events in CM system
807 ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
808 READ(NUMBER,*) ECM,NEV
809 WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
810 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
811 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
812 CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
813 E1 = EE
814 E2 = ECM-EE
815 THETA = 0.D0
816 PHI = 0.D0
817 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
818 KEVENT = 0
819
820C fixed-energy events for collider setup with crossing angle
821 ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
822 READ(NUMBER,*) E1,E2,THETA,PHI,NEV
823 WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
824 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
825 KEVENT = 0
826
827C unknown data card
828 ELSE
829 WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
830 ENDIF
831
832 GOTO 1200
833 1300 CONTINUE
834 WRITE(LO,*) ' RETURN'
835
836 END
837
838*$ CREATE PHO_SETMDL.FOR
839*COPY PHO_SETMDL
840CDECK ID>, PHO_SETMDL
841 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
842C**********************************************************************
843C
844C set model switches
845C
846C input: INDX model parameter number
847C (positive: ISWMDL, negative: IPAMDL)
848C IVAL new value
849C IMODE -1 print value of parameter INDX
850C 1 set new value
851C -2 print current settings
852C
853C**********************************************************************
854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
855 SAVE
856
857C input/output channels
858 INTEGER LI,LO
859 COMMON /POINOU/ LI,LO
860C model switches and parameters
861 CHARACTER*8 MDLNA
862 INTEGER ISWMDL,IPAMDL
863 DOUBLE PRECISION PARMDL
864 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
865
866 IF(IMODE.EQ.-2) THEN
867 WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
868 & '----------------------------'
869 DO 100 I=1,48,3
870 IF(ISWMDL(I).EQ.-9999) GOTO 200
871 IF(ISWMDL(I+1).EQ.-9999) THEN
872 WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
873 GOTO 200
874 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
875 WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
876 & I+1,':',MDLNA(I+1),ISWMDL(I+1)
877 GOTO 200
878 ELSE
879 WRITE(LO,'(3(5X,I3,A1,A,I6))')
880 & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
881 ENDIF
882 100 CONTINUE
883 200 CONTINUE
884 ELSE IF(IMODE.EQ.-1) THEN
885 WRITE(LO,'(1X,A,1X,A,I6)')
886 & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
887 ELSE IF(IMODE.EQ.1) THEN
888 IF(INDX.GT.0) THEN
889 IF(ISWMDL(INDX).NE.IVAL) THEN
890 WRITE(LO,'(1X,A,I4,1X,A,2I6)')
891 & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
892 & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
893 ISWMDL(INDX) = IVAL
894 ENDIF
895 ELSE IF(INDX.LT.0) THEN
896 IF(IPAMDL(-INDX).NE.IVAL) THEN
897 WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
898 & -INDX,IPAMDL(-INDX),IVAL
899 IPAMDL(-INDX) = IVAL
900 ENDIF
901 ENDIF
902 ELSE
903 WRITE(LO,'(/1X,A,I6)')
904 & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
905 ENDIF
906 END
907
908*$ CREATE PHO_DATINI.FOR
909*COPY PHO_DATINI
910CDECK ID>, PHO_DATINI
911 SUBROUTINE PHO_DATINI
912C*********************************************************************
913C
914C initialization of variables and switches
915C
916C*********************************************************************
917 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
918 SAVE
919
920C input/output channels
921 INTEGER LI,LO
922 COMMON /POINOU/ LI,LO
923C some constants
924 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
925 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
926 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
927C event debugging information
928 INTEGER NMAXD
929 PARAMETER (NMAXD=100)
930 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
931 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
932 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
933 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
934C event weights and generated cross section
935 INTEGER IPOWGC,ISWCUT,IVWGHT
936 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
937 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
938 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
939C scale parameters for parton model calculations
940 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
941 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
942 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
943 & NQQAL,NQQALI,NQQALF,NQQPD
944C integration precision for hard cross sections (obsolete)
945 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
946 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
947C hard scattering parameters used for most recent hard interaction
948 INTEGER NFbeta,NF
949 DOUBLE PRECISION ALQCD2,BQCD
950 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
951C cut probability distribution
952 INTEGER IEETA1,IIMAX,KKMAX
953 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
954 INTEGER IEEMAX,IMAX,KMAX
955 REAL PROB
956 DOUBLE PRECISION EPTAB
957 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
958 & IEEMAX,IMAX,KMAX
959C gamma-lepton or gamma-hadron vertex information
960 INTEGER IGHEL,IDPSRC,IDBSRC
961 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
962 & RADSRC,AMSRC,GAMSRC
963 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
964 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
965 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
966C photon flux kinematics and cuts
967 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
968 & YMIN1,YMAX1,YMIN2,YMAX2,
969 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
970 & THMIN1,THMAX1,THMIN2,THMAX2
971 INTEGER ITAG1,ITAG2
972 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
973 & YMIN1,YMAX1,YMIN2,YMAX2,
974 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
975 & THMIN1,THMAX1,THMIN2,THMAX2,
976 & ITAG1,ITAG2
977C obsolete cut-off information
978 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
979 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
980C global event kinematics and particle IDs
981 INTEGER IFPAP,IFPAB
982 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
983 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
984C nucleon-nucleus / nucleus-nucleus interface to DPMJET
985 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
986 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
987 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
988 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
989C some hadron information, will be deleted in future versions
990 INTEGER NFS
991 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
992 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
993C model switches and parameters
994 CHARACTER*8 MDLNA
995 INTEGER ISWMDL,IPAMDL
996 DOUBLE PRECISION PARMDL
997 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
998C general process information
999 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1000 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1001C parameters of the "simple" Vector Dominance Model
1002 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1003 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1004C parameters for DGLAP backward evolution in ISR
1005 INTEGER NFSISR
1006 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1007 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1008C particles created by initial state evolution
1009 INTEGER MXISR1,MXISR2
1010 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1011 INTEGER IFLISR,IPOISR,IMXISR
1012 DOUBLE PRECISION PHISR
1013 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1014 & IPOISR(2,2,MXISR2),IMXISR(2)
1015C names of hard scattering processes
1016 INTEGER Max_pro_1
1017 PARAMETER ( Max_pro_1 = 16 )
1018 CHARACTER*18 PROC
1019 COMMON /POHPRO/ PROC(0:Max_pro_1)
1020C hard cross sections and MC selection weights
1021 INTEGER Max_pro_2
1022 PARAMETER ( Max_pro_2 = 16 )
1023 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1024 & MH_acc_1,MH_acc_2
1025 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1026 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1027 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1028 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1029 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1030 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1031C interpolation tables for hard cross section and MC selection weights
1032 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1033 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1034 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1035 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1036 & HQ2a_tab,HQ2b_tab,HEcm_tab
1037 COMMON /POHTAB/
1038 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1039 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1040 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1041 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1042 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1043 & HEcm_tab(1:Max_tab_E,0:4),
1044 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1045
1046C initialize /POCONS/
1047 PI = ATAN(1.D0)*4.D0
1048 PI2 = 2.D0*PI
1049 PI4 = 2.D0*PI2
1050C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1051 GEV2MB = 0.389365D0
1052C precalculate quark charges
1053 do i=1,6
1054 Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1055 Q_ch(-i) = -Q_ch(i)
1056
1057 Q_ch2(i) = Q_ch(i)**2
1058 Q_ch2(-i) = Q_ch2(i)
1059
1060 Q_ch4(i) = Q_ch2(i)**2
1061 Q_ch4(-i) = Q_ch4(i)
1062 enddo
1063 Q_ch(0) = 0.D0
1064 Q_ch2(0) = 0.D0
1065 Q_ch4(0) = 0.D0
1066
1067C initialize /GLOCMS/
1068 ECM = 50.D0
1069 PMASS(1) = 0.D0
1070 PVIRT(1) = 0.D0
1071 PMASS(2) = 0.D0
1072 PVIRT(2) = 0.D0
1073 IFPAP(1) = 22
1074 IFPAP(2) = 22
1075C initialize /HADVAL/
1076 IHFLD(1,1) = 0
1077 IHFLD(1,2) = 0
1078 IHFLD(2,1) = 0
1079 IHFLD(2,2) = 0
1080 IHFLS(1) = 1
1081 IHFLS(2) = 1
1082C initialize /MODELS/
1083 ISWMDL(1) = 3
1084 MDLNA(1) = 'AMPL MOD'
1085 ISWMDL(2) = 1
1086 MDLNA(2) = 'MIN-BIAS'
1087 ISWMDL(3) = 1
1088 MDLNA(3) = 'PTS DISH'
1089 ISWMDL(4) = 1
1090 MDLNA(4) = 'PTS DISP'
1091 ISWMDL(5) = 2
1092 MDLNA(5) = 'PTS ASSI'
1093 ISWMDL(6) = 3
1094 MDLNA(6) = 'HADRONIZ'
1095 ISWMDL(7) = 2
1096 MDLNA(7) = 'MASS COR'
1097 ISWMDL(8) = 3
1098 MDLNA(8) = 'PAR SHOW'
1099 ISWMDL(9) = 0
1100 MDLNA(9) = 'GLU SPLI'
1101 ISWMDL(10) = 2
1102 MDLNA(10) = 'VIRT PHO'
1103 ISWMDL(11) = 0
1104 MDLNA(11) = 'LARGE NC'
1105 ISWMDL(12) = 0
1106 MDLNA(12) = 'LIPA POM'
1107 ISWMDL(13) = 1
1108 MDLNA(13) = 'QELAS VM'
1109 ISWMDL(14) = 2
1110 MDLNA(14) = 'ENHA GRA'
1111 ISWMDL(15) = 4
1112 MDLNA(15) = 'MULT SCA'
1113 ISWMDL(16) = 4
1114 MDLNA(16) = 'MULT DIF'
1115 ISWMDL(17) = 4
1116 MDLNA(17) = 'MULT CDF'
1117 ISWMDL(18) = 0
1118 MDLNA(18) = 'BALAN PT'
1119 ISWMDL(19) = 1
1120 MDLNA(19) = 'POMV FLA'
1121 ISWMDL(20) = 0
1122 MDLNA(20) = 'SEA FLA'
1123 ISWMDL(21) = 2
1124 MDLNA(21) = 'SPIN DEC'
1125 ISWMDL(22) = 1
1126 MDLNA(22) = 'DIF.MASS'
1127 ISWMDL(23) = 1
1128 MDLNA(23) = 'DIFF RES'
1129 ISWMDL(24) = 0
1130 MDLNA(24) = 'PTS HPOM'
1131 ISWMDL(25) = 0
1132 MDLNA(25) = 'POM CORR'
1133 ISWMDL(26) = 1
1134 MDLNA(26) = 'OVERLAP '
1135 ISWMDL(27) = 0
1136 MDLNA(27) = 'MUL R/AN'
1137 ISWMDL(28) = 1
1138 MDLNA(28) = 'SUR PROB'
1139 ISWMDL(29) = 1
1140 MDLNA(29) = 'PRIMO KT'
1141 ISWMDL(30) = 0
1142 MDLNA(30) = 'DIFF. CS'
1143 ISWMDL(31) = -9999
1144C mass-independent sea flavour ratios (for low-mass strings)
1145 PARMDL(1) = 0.425D0
1146 PARMDL(2) = 0.425D0
1147 PARMDL(3) = 0.15D0
1148 PARMDL(4) = 0.D0
1149 PARMDL(5) = 0.D0
1150 PARMDL(6) = 0.D0
1151C suppression by energy momentum conservation
1152 PARMDL(8) = 9.D0
1153 PARMDL(9) = 7.D0
1154C VDM factors
1155 PARMDL(10) = 0.866D0
1156 PARMDL(11) = 0.288D0
1157 PARMDL(12) = 0.288D0
1158 PARMDL(13) = 0.288D0
1159 PARMDL(14) = 0.866D0
1160 PARMDL(15) = 0.288D0
1161 PARMDL(16) = 0.288D0
1162 PARMDL(17) = 0.288D0
1163 PARMDL(18) = 0.D0
1164C lower energy limit for initialization
1165 PARMDL(19) = 5.D0
1166C soft pt for hard scattering remnants
1167 PARMDL(20) = 5.D0
1168C low energy beta of soft pt distribution 1
1169 PARMDL(21) = 4.5D0
1170C high energy beta of soft pt distribution 1
1171 PARMDL(22) = 3.0D0
1172C low energy beta of soft pt distribution 0
1173 PARMDL(23) = 2.5D0
1174C high energy beta of soft pt distribution 0
1175 PARMDL(24) = 0.4D0
1176C effective quark mass in photon wave function
1177 PARMDL(25) = 0.2D0
1178C normalization of unevolved Pomeron PDFs
1179 PARMDL(26) = 0.3D0
1180C effective VDM parameters for Q**2 dependence of cross section
1181 PARMDL(27) = 0.65D0
1182 PARMDL(28) = 0.08D0
1183 PARMDL(29) = 0.05D0
1184 PARMDL(30) = 0.22D0
1185 PARMDL(31) = 0.589824D0
1186 PARMDL(32) = 0.609961D0
1187 PARMDL(33) = 1.038361D0
1188 PARMDL(34) = 1.96D0
1189C Q**2 suppression of multiple interactions
1190 PARMDL(35) = 0.59D0
1191C pt cutoff defaults
1192 PARMDL(36) = 2.5D0
1193 PARMDL(37) = 2.5D0
1194 PARMDL(38) = 2.5D0
1195 PARMDL(39) = 2.5D0
1196C enhancement factor for diffractive cross sections
1197 PARMDL(40) = 1.D0
1198 PARMDL(41) = 1.D0
1199 PARMDL(42) = 1.D0
1200C mass in soft pt distribution
1201 PARMDL(43) = 0.D0
1202C maximum of x allowed for leading particle
1203 PARMDL(44) = 0.9D0
1204C max. mass sampled in diffraction
1205 PARMDL(45) = sqrt(0.4D0)
1206C mass threshold in diffraction (2pi mass)
1207 PARMDL(46) = 0.3D0
1208C regularization of slope parameter in diffraction
1209 PARMDL(47) = 4.D0
1210C renormalized intercept for enhanced graphs
1211 PARMDL(48) = 1.08D0
1212C coherence constraint for diff. cross sections
1213 PARMDL(49) = sqrt(0.05D0)
1214C exponents of x distributions
1215C baryon
1216 PARMDL(50) = 1.5D0
1217 PARMDL(51) = -0.5D0
1218 PARMDL(52) = -0.99D0
1219 PARMDL(53) = -0.99D0
1220C meson (non-strangeness part)
1221 PARMDL(54) = -0.5D0
1222 PARMDL(55) = -0.5D0
1223 PARMDL(56) = -0.99D0
1224 PARMDL(57) = -0.99D0
1225C meson (strangeness part)
1226 PARMDL(58) = -0.2D0
1227 PARMDL(59) = -0.2D0
1228 PARMDL(60) = -0.99D0
1229 PARMDL(61) = -0.99D0
1230C particle remnant (no valence quarks)
1231 PARMDL(62) = -0.5D0
1232 PARMDL(63) = -0.5D0
1233 PARMDL(64) = -0.99D0
1234 PARMDL(65) = -0.99D0
1235C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1236 PARMDL(66) = 10.D0
1237C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1238 PARMDL(67) = 10.D0
1239C min. abs(t) in diffraction
1240 PARMDL(68) = 0.D0
1241C max. abs(t) in diffraction
1242 PARMDL(69) = 10.D0
1243C min. mass for elastic pomerons in central diffraction
1244 PARMDL(70) = 2.D0
1245C min. mass of diffractive blob in central diffraction
1246 PARMDL(71) = 2.D0
1247C min. Feynman x cut in central diffraction
1248 PARMDL(72) = 0.D0
1249C direct pomeron coupling
1250 PARMDL(74) = 0.D0
1251C relative deviation allowed for energy-momentum conservation
1252C energy-momentum relative deviation
1253 PARMDL(75) = 0.01D0
1254C transverse momentum deviation
1255 PARMDL(76) = 0.01D0
1256C couplings for unitarization in diffraction
1257C non-unitarized pomeron coupling (sqrt(mb))
1258 PARMDL(77) = 3.D0
1259C rescaling factor for pomeron PDF
1260 PARMDL(78) = 3.D0
1261C coupling probabilities
1262 PARMDL(79) = 1.D0
1263 PARMDL(80) = 0.D0
1264C scales to calculate alpha-s of matrix element
1265 PARMDL(81) = 1.D0
1266 PARMDL(82) = 1.D0
1267 PARMDL(83) = 1.D0
1268C scales to calculate alpha-s of initial state radiation
1269 PARMDL(84) = 1.D0
1270 PARMDL(85) = 1.D0
1271 PARMDL(86) = 1.D0
1272C scales to calculate alpha-s of final state radiation
1273 PARMDL(87) = 1.D0
1274 PARMDL(88) = 1.D0
1275 PARMDL(89) = 1.D0
1276C scales to calculate PDFs
1277 PARMDL(90) = 1.D0
1278 PARMDL(91) = 1.D0
1279 PARMDL(92) = 1.D0
1280C scale for ISR starting virtuality
1281 PARMDL(93) = 1.D0
1282C min. virtuality to generate time-like showers in ISR
1283 PARMDL(94) = 2.D0
1284C factor to scale the max. allowed time-like parton shower virtuality
1285 PARMDL(95) = 4.D0
1286C max. transverse momentum for primordial kt
1287 PARMDL(100) = 2.D0
1288C weight factors for pt-distribution
1289 PARMDL(101) = 2.D0
1290 PARMDL(102) = 2.D0
1291 PARMDL(103) = 4.D0
1292 PARMDL(104) = 2.D0
1293 PARMDL(105) = 6.D0
1294 PARMDL(106) = 4.D0
1295C
1296* PARMDL(110-125) reserved for hard scattering
1297C currently chosen scales for hard scattering
1298 DO 10 I=1,16
1299 PARMDL(109+I) = 0.D0
1300 10 CONTINUE
1301C virtuality cutoff in initial state evolution
1302 PARMDL(126) = PARMDL(36)**2
1303 PARMDL(127) = PARMDL(37)**2
1304 PARMDL(128) = PARMDL(38)**2
1305 PARMDL(129) = PARMDL(39)**2
1306C virtuality cutoff for direct contribution to photon PDF
1307 PARMDL(130) = 1.D30
1308 PARMDL(131) = 1.D30
1309 PARMDL(132) = 1.D30
1310 PARMDL(133) = 1.D30
1311C fraction of events without popcorn
1312 PARMDL(134) = -1.D0
1313C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1314 PARMDL(135) = 0.5D0
1315C soft color re-connection (fraction)
1316C g g final state
1317 PARMDL(140) = 1.D0/64.D0
1318C g q final state
1319 PARMDL(141) = 1.D0/24.D0
1320C q q final state
1321 PARMDL(142) = 1.D0/9.D0
1322C effective scale in Drees-Godbole like suppresion in photon PDF
1323 PARMDL(144) = 0.766D0**2
1324C QCD scales (if PDF scales are not used, 4 active flavours)
1325 PARMDL(145) = 0.2D0**2
1326 PARMDL(146) = 0.2D0**2
1327 PARMDL(147) = 0.2D0**2
1328C threshold scales for variable flavour calculation (GeV**2)
1329 PARMDL(148) = 1.5D0**2
1330 PARMDL(149) = 4.5D0**2
1331 PARMDL(150) = 175.D0**2
1332C constituent quark masses
1333 PARMDL(151) = 0.3D0
1334 PARMDL(152) = 0.3D0
1335 PARMDL(153) = 0.5D0
1336 PARMDL(154) = 1.6D0
1337 PARMDL(155) = 5.D0
1338 PARMDL(156) = 174.D0
1339C min. masses of valence quark
1340 PARMDL(157) = 0.3D0
1341C min. masses of valence diquark
1342 PARMDL(158) = 0.8D0
1343C min. mass of sea quark
1344 PARMDL(159) = 0.D0
1345C suppression of strange quarks as photon valences
1346 PARMDL(160) = 0.2D0
1347C min. masses for strings (used in PHO_SOFTXX)
1348 PARMDL(161) = 1.D0
1349 PARMDL(162) = 1.D0
1350 PARMDL(163) = 1.D0
1351 PARMDL(164) = 1.D0
1352C min. momentum fraction for soft processes
1353 PARMDL(165) = 0.3D0
1354C min. phase space for x-sampling
1355 PARMDL(166) = 0.135D0
1356C Ross-Stodolsky exponent
1357 PARMDL(170) = 4.2D0
1358C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1359 PARMDL(175) = 2.D0
1360**sr
1361* extra factor multiplying difference between Goulianos and PHOJET-
1362* diff. cross sections
1363 PARMDL(200) = 0.6D0
1364**
1365C complex amplitudes, eikonal functions
1366 IPAMDL(1) = 0
1367C allow for Reggeon cuts
1368 IPAMDL(2) = 1
1369C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1370 IPAMDL(3) = 0
1371C polarization of photon resonances (0 none, 1 trans, 2 long)
1372 IPAMDL(4) = 1
1373C pt of valence partons
1374 IPAMDL(5) = 1
1375C pt of hard scattering remnant
1376 IPAMDL(6) = 2
1377C running cutoff for hard scattering
1378 IPAMDL(7) = 1
1379C intercept used for the calculation of enhanced graphs
1380 IPAMDL(8) = 1
1381C effective slope of hard scattering amplitde
1382 IPAMDL(9) = 1
1383C mass dependence of slope parameters
1384 IPAMDL(10) = 0
1385C lepton-photon vertex 1
1386 IPAMDL(11) = 0
1387C lepton-photon vertex 2
1388 IPAMDL(12) = 0
1389C call by DPMJET
1390 IPAMDL(13) = 0
1391C method to sample x distributions
1392 IPAMDL(14) = 3
1393C energy-momentum check
1394 IPAMDL(15) = 1
1395C phase space correction for DPMJET interface
1396 IPAMDL(16) = 1
1397C fragment strings from projectile/target/central diff. separately
1398 IPAMDL(17) = 1
1399C method to construct strings for hard interactions
1400 IPAMDL(18) = 1
1401C method to construct strings for soft sea (pomeron cuts)
1402 IPAMDL(19) = 0
1403C method to construct strings in pomeron interactions
1404 IPAMDL(20) = 0
1405C soft color re-connection
1406 IPAMDL(21) = 0
1407C resummation of triple- and loop-Pomeron
1408 IPAMDL(24) = 1
1409C resummation of X iterated triple-Pomeron
1410 IPAMDL(25) = 1
1411C dimension of interpolation table for weights in hard scattering
1412 IPAMDL(30) = Max_tab_E
1413C dimension of interpolation table for pomeron cut distribution
1414 IPAMDL(31) = IEETA1
1415C number of cut soft pomerons (restriction by field dimension)
1416 IPAMDL(32) = IIMAX
1417C number of cut hard pomerons (restriction by field dimension)
1418 IPAMDL(33) = KKMAX
1419C tau pair production in direct photon-photon collisions
1420 IPAMDL(64) = 0
1421C currently chosen scales for hard scattering
1422C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1423 DO 15 I=1,16
1424 IPAMDL(64+I) = -99999
1425 15 CONTINUE
1426C scales to calculate alpha-s of matrix element
1427 IPAMDL(81) = 1
1428 IPAMDL(82) = 1
1429 IPAMDL(83) = 1
1430C scales to calculate alpha-s of initial state radiation
1431 IPAMDL(84) = 1
1432 IPAMDL(85) = 1
1433 IPAMDL(86) = 1
1434C scales to calculate alpha-s of final state radiation
1435 IPAMDL(87) = 1
1436 IPAMDL(88) = 1
1437 IPAMDL(89) = 1
1438C scales to calculate PDFs
1439 IPAMDL(90) = 1
1440 IPAMDL(91) = 1
1441 IPAMDL(92) = 1
1442C where to get the parameter sets from
1443 IPAMDL(99) = 1
1444C program PHO_ABORT for fatal errors (simulation of division by zero)
1445 IPAMDL(100) = 0
1446C initial state parton showers for all / hardest interaction(s)
1447 IPAMDL(101) = 1
1448C final state parton showers for all / hardest interaction(s)
1449 IPAMDL(102) = 1
1450C initial virtuality for ISR generation
1451 IPAMDL(109) = 1
1452C qqbar-gamma coupling in initial state showers
1453 IPAMDL(110) = 1
1454C generation of time-like showers during ISR
1455 IPAMDL(111) = 1
1456C reweighting of multiple soft contributions for virtual photons
1457 IPAMDL(114) = 1
1458C reweighting / use photon virtuality in photon PDF calculations
1459 IPAMDL(115) = 0
1460C use full QPM model incl. interference terms (direct part in gam-gam)
1461 IPAMDL(116) = 0
1462C matching sigma_tot to F2 as given by parton density at high Q2
1463 IPAMDL(117) = 1
1464C use virtuality of target in F2 calculations (two-gamma only)
1465 IPAMDL(118) = 1
1466C calculation of alpha_em
1467 IPAMDL(120) = 1
1468C strict pt cutoff for gamma-gamma events
1469 IPAMDL(121) = 0
1470C photon virtuality sampled in photon flux approximations
1471 IPAMDL(174) = 1
1472C photon-pomeron: 0,1,2: both,left,right photon emission
1473 IPAMDL(175) = 0
1474C keep full history information in PHOJET-JETSET interface
1475 IPAMDL(178) = 1
1476C max. number of conservation law violations allowed in one run
1477 IPAMDL(179) = 20
1478C selection of soft X values
1479C max. iteration number in PHO_SELSXS
1480 IPAMDL(180) = 50
1481C max. iteration number in PHO_SELSXR
1482 IPAMDL(181) = 200
1483C max. iteration number in PHO_SELSX2
1484 IPAMDL(182) = 100
1485C max. iteration number in PHO_SELSXI
1486 IPAMDL(183) = 50
1487
1488C initialize /PROBAB/
1489 IEEMAX = IEETA1
1490 IMAX = IIMAX
1491 KMAX = KKMAX
1492
1493 DO 20 I=1,30
1494 PARMDL(300+I) = -100000.D0
1495 20 CONTINUE
1496C initialize /POHDRN/
1497 QMASS(1) = PARMDL(151)
1498 QMASS(2) = PARMDL(152)
1499 QMASS(3) = PARMDL(153)
1500 QMASS(4) = PARMDL(154)
1501 QMASS(5) = PARMDL(155)
1502 QMASS(6) = PARMDL(156)
1503 BET = 8.D0
1504 PCOUDI = 0.D0
1505 VALPRG(1) = 1.D0
1506 VALPRG(2) = 1.D0
1507C number of light flavours (quarks treated as massless)
1508 NFS = 4
1509C initialize /POCUT1/
1510 PTCUT(1) = PARMDL(36)
1511 PTCUT(2) = PARMDL(37)
1512 PTCUT(3) = PARMDL(38)
1513 PTCUT(4) = PARMDL(39)
1514 PSOMIN = 0.D0
1515 XSOMIN = 0.D0
1516C initialize /POHAPA/
1517 NFbeta = 4
1518 NF = 4
1519 BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1520 BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1521 BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1522 BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1523C initialize /POGAUP/
1524 NGAUP1 = 12
1525 NGAUP2 = 12
1526 NGAUET = 16
1527 NGAUIN = 12
1528 NGAUSO = 96
1529C initialize //
1530 DO 30 I=1,100
1531 IDEB(I) = 0
1532 30 CONTINUE
1533C initialize /PROCES/
1534 DO 35 I=1,11
1535 IPRON(I,1) = 1
1536 35 CONTINUE
1537C DPMJET default: no elastic scattering
1538 IPRON(2,1) = 0
1539 DO 36 K=2,4
1540 DO 37 I=2,11
1541 IPRON(I,K) = 0
1542 37 CONTINUE
1543 IPRON(1,K) = 1
1544 IPRON(8,K) = 1
1545 36 CONTINUE
1546C initialize /POSVDM/
1547 TWOPIM = 0.28D0
1548 RMIN(1) = 0.285D0
1549 RMIN(2) = 0.45D0
1550 RMIN(3) = 1.D0
1551 RMIN(4) = TWOPIM
1552 VMAS(1) = 0.770D0
1553 VMAS(2) = 0.787D0
1554 VMAS(3) = 1.02D0
1555 VMAS(4) = TWOPIM
1556 GAMM(1) = 0.155D0
1557 GAMM(2) = 0.01D0
1558 GAMM(3) = 0.0045D0
1559 GAMM(4) = 1.D0
1560 RMAX(1) = VMAS(1)+TWOPIM
1561 RMAX(2) = VMAS(2)+TWOPIM
1562 RMAX(3) = VMAS(3)+TWOPIM
1563 RMAX(4) = VMAS(1)+TWOPIM
1564 VMSL(1) = 11.D0
1565 VMSL(2) = 10.D0
1566 VMSL(3) = 6.D0
1567 VMSL(4) = 4.D0
1568 VMFA(1) = 0.0033D0
1569 VMFA(2) = 0.00036D0
1570 VMFA(3) = 0.0002D0
1571 VMFA(4) = 0.0002D0
1572C initialize /PODGL1/
1573 Q2MISR(1) = PARMDL(36)**2
1574 Q2MISR(2) = PARMDL(36)**2
1575 PMISR(1) = 1.D0
1576 PMISR(2) = 1.D0
1577 ZMISR(1) = 0.001D0
1578 ZMISR(2) = 0.001D0
1579 AL2ISR(1) = 0.046D0
1580 AL2ISR(2) = 0.046D0
1581 NFSISR = 4
1582C initialize /POPISR/
1583 DO 40 I=1,50
1584 IPOISR(1,2,I) = 0
1585 IPOISR(2,2,I) = 0
1586 40 CONTINUE
1587C initialize /POHPRO/
1588 PROC(0) = 'sum over processes'
1589 PROC(1) = 'G +G --> G +G '
1590 PROC(2) = 'Q +QB --> G +G '
1591 PROC(3) = 'G +Q --> G +Q '
1592 PROC(4) = 'G +G --> Q +QB '
1593 PROC(5) = 'Q +QB --> Q +QB '
1594 PROC(6) = 'Q +QB --> QP +QBP'
1595 PROC(7) = 'Q +Q --> Q +Q '
1596 PROC(8) = 'Q +QP --> Q +QP '
1597 PROC(9) = 'resolved processes'
1598 PROC(10) = 'gam+Q --> G +Q '
1599 PROC(11) = 'gam+G --> Q +QB '
1600 PROC(12) = 'Q +gam--> G +Q '
1601 PROC(13) = 'G +gam--> Q +QB '
1602 PROC(14) = 'gam+gam--> Q +QB '
1603 PROC(15) = 'direct processes '
1604 PROC(16) = 'gam+gam--> l+ +l- '
1605
1606C initialize /POHRCS/
1607 do M=1,Max_pro_2
1608 HWgx(M) = 0.D0
1609 HSig(M) = 0.D0
1610 Hdpt(M) = 0.D0
1611 enddo
1612 DO I=0,4
1613 DO M=-1,Max_pro_2
1614C switch all hard subprocesses on
1615 MH_pro_on(M,I) = 1
1616C reset all counters
1617 MH_tried(M,I) = 0
1618 MH_acc_1(M,I) = 0
1619 MH_acc_2(M,I) = 0
1620 ENDDO
1621 MH_pro_on(16,I) = 0
1622 ENDDO
1623
1624C initialize /POHTAB/
1625 do I=0,4
1626 IH_Ecm_up(I) = 0
1627 IH_Q2a_up(I) = 0
1628 IH_Q2b_up(I) = 0
1629 HEcm_tab(1,I) = 0.D0
1630 enddo
1631 HEcm_last = 0.D0
1632 IHa_last = 0.D0
1633 IHb_last = 0.D0
1634
1635C initialize /POFSRC/
1636 IGHEL(1) = -1
1637 IGHEL(2) = -1
1638C initialize /LEPCUT/
1639 ECMIN = 5.D0
1640 ECMAX = 1.D+30
1641 EEMIN1 = 1.D0
1642 EEMIN2 = 1.D0
1643 YMAX1 = -1.D0
1644 YMAX2 = -1.D0
1645 THMIN1 = 0.D0
1646 THMAX1 = PI
1647 THMIN2 = 0.D0
1648 THMAX2 = PI
1649 ITAG1 = 1
1650 ITAG2 = 1
1651C initialize /POWGHT/
1652 DO 70 I=1,20
1653 HSWCUT(I) = 0.D0
1654 ISWCUT(I) = 0
1655 70 CONTINUE
1656 EVWGHT(1) = 1.D0
1657 IVWGHT(1) = 0
1658 SIGGEN(1) = 0.D0
1659 SIGGEN(2) = 0.D0
1660 SIGGEN(3) = 0.D0
1661 SIGGEN(4) = 0.D0
1662
1663 END
1664
1665*$ CREATE PHO_PARDAT.FOR
1666*COPY PHO_PARDAT
1667CDECK ID>, PHO_PARDAT
1668 SUBROUTINE PHO_PARDAT
1669C***********************************************************************
1670C
1671C particle data (based on 1996 PDG naming scheme and data tables)
1672C
1673C***********************************************************************
1674 IMPLICIT NONE
1675 SAVE
1676
1677C input/output channels
1678 INTEGER LI,LO
1679 COMMON /POINOU/ LI,LO
1680C event debugging information
1681 INTEGER NMAXD
1682 PARAMETER (NMAXD=100)
1683 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
1684 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1685 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
1686 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1687C particle ID translation table
1688 integer ID_pdg_list,ID_list,ID_pdg_max
1689 character*12 name_list
1690 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
1691 & ID_pdg_max
1692C general particle data
1693 double precision xm_list,tau_list,gam_list,
1694 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
1695 & xm_bb82_list,xm_bb102_list
1696 integer ich3_list,iba3_list,iq_list,
1697 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
1698 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
1699 & xm_psm2_list(6,6),xm_vem2_list(6,6),
1700 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
1701 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
1702 & ich3_list(300),iba3_list(300),iq_list(3,300),
1703 & id_psm_list(6,6),id_vem_list(6,6),
1704 & id_b8_list(6,6,6),id_b10_list(6,6,6)
1705C particle decay data
1706 double precision wg_sec_list
1707 integer idec_list,isec_list
1708 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
1709 & isec_list(3,500)
1710
1711C external functions
1712
1713 integer ipho_pdg2id
1714 double precision pho_pmass
1715
1716C local variables for storing data tables
1717
1718 integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
1719 & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
1720
1721 dimension number(300),ich3(300),iba3(300),iq_linear(900),
1722 & idec_linear(900),isec_linear(900),id_psm_linear(36),
1723 & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
1724
1725 double precision xmass,gamma,wg_chan
1726 dimension xmass(300),gamma(300),wg_chan(300)
1727
1728 character*12 name
1729 dimension name(300)
1730
1731 integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
1732 double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
1733 integer itmp
1734
1735 DATA i_tab_max /260/
1736
1737 DATA (number(K),K= 1, 171) /
1738 & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
1739 & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
1740 & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
1741 & 110, 990, 21, 22, 24, 23, 11, 13, 15,
1742 & 12, 14, 16, 211, 111, 221, 113, 213, 223,
1743 & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
1744 & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
1745 & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
1746 & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
1747 & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
1748 & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
1749 & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
1750 & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
1751 & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
1752 & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
1753 & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
1754 & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
1755 & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
1756 & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
1757 DATA (number(K),K= 172, 260) /
1758 & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
1759 & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
1760 & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
1761 & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
1762 & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
1763 & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
1764 & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
1765 & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
1766 & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
1767 & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
1768 DATA (name(K),K= 1, 76) /
1769 &'d ','u ','s ','c ',
1770 &'b ','t ','(dd)_1 ','(ud)_0 ',
1771 &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
1772 &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
1773 &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
1774 &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
1775 &'string ','mod. string ','coll. string','reggeon ',
1776 &'pomeron ','gluon ','gamma ','W ',
1777 &'Z ','e ','mu ','tau ',
1778 &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
1779 &'pi ','eta ','rho(770) ','rho(770) ',
1780 &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
1781 &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
1782 &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
1783 &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
1784 &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
1785 &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
1786 &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
1787 &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
1788 DATA (name(K),K= 77, 152) /
1789 &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
1790 &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
1791 &'K ','K(S) ','K(L) ','K*(892) ',
1792 &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
1793 &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
1794 &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
1795 &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
1796 &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
1797 &'K(4)*(2045) ','D ','D ','D*(2007) ',
1798 &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
1799 &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
1800 &'B ','B* ','B* ','B(s) ',
1801 &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
1802 &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
1803 &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
1804 &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
1805 &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
1806 &'Ups(10860) ','Ups(11020) ','p ','n ',
1807 &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
1808 DATA (name(K),K= 153, 228) /
1809 &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
1810 &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
1811 &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
1812 &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
1813 &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
1814 &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
1815 &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
1816 &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
1817 &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
1818 &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
1819 &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
1820 &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
1821 &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
1822 &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
1823 &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
1824 &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
1825 &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
1826 &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
1827 &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
1828 DATA (name(K),K= 229, 260) /
1829 &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
1830 &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
1831 &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
1832 &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
1833 &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
1834 &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
1835 &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
1836 &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
1837 DATA (ich3(K),K= 1, 260) /
1838 &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
1839 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
1840 & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
1841 & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
1842 & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
1843 & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1844 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
1845 & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
1846 &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
1847 & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
1848 & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
1849 & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
1850 DATA (iba3(K),K= 1, 260) /
1851 &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,
1852 &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,
1853 &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,
1854 &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,
1855 &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,
1856 &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,
1857 &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,
1858 &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/
1859 DATA (iq_linear(K),K= 1, 418) /
1860 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
1861 & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
1862 & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
1863 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1864 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1865 & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1866 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
1867 &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
1868 & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1869 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
1870 &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
1871 & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
1872 & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
1873 &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
1874 & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
1875 & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
1876 &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
1877 & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
1878 & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
1879 DATA (iq_linear(K),K= 419, 780) /
1880 &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
1881 & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
1882 & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
1883 & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
1884 & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
1885 & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
1886 & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
1887 & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
1888 & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
1889 & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
1890 & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
1891 & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
1892 & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
1893 & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
1894 & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
1895 & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
1896 & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
1897 DATA (xmass(K),K= 1, 114) /
1898 &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
1899 &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
1900 &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
1901 &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
1902 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1903 &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
1904 &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
1905 &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
1906 &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
1907 &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
1908 &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
1909 &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
1910 &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
1911 &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
1912 &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
1913 &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
1914 &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
1915 &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
1916 &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
1917 DATA (xmass(K),K= 115, 228) /
1918 &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
1919 &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
1920 &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
1921 &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
1922 &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
1923 &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
1924 &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
1925 &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
1926 &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
1927 &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
1928 &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
1929 &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
1930 &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
1931 &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
1932 &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
1933 &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
1934 &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
1935 &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
1936 &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
1937 DATA (xmass(K),K= 229, 260) /
1938 &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
1939 &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
1940 &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
1941 &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
1942 &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
1943 &2.7040E+00,5.6240E+00/
1944 DATA (gamma(K),K= 1, 114) /
1945 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1946 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1947 &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
1948 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1949 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1950 &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
1951 &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
1952 &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
1953 &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
1954 &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
1955 &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
1956 &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
1957 &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
1958 &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
1959 &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
1960 &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
1961 &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
1962 &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
1963 &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
1964 DATA (gamma(K),K= 115, 228) /
1965 &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
1966 &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
1967 &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
1968 &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
1969 &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
1970 &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
1971 &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1972 &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
1973 &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
1974 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
1975 &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1976 &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
1977 &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
1978 &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
1979 &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
1980 &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
1981 &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
1982 &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
1983 &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
1984 DATA (gamma(K),K= 229, 260) /
1985 &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
1986 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
1987 &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
1988 &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
1989 &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
1990 &1.0200E-11,5.3100E-13/
1991 DATA (idec_linear(K),K= 1, 304) /
1992 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1993 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1994 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1995 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1996 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1997 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1998 & 0, 0, 0, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
1999 & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
2000 & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
2001 & 0, 0, 0, 1, 25, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2002 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2003 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 30, 32,
2004 & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
2005 & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
2006 & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2007 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
2008 & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
2009 & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
2010 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
2011 DATA (idec_linear(K),K= 305, 608) /
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, 2, 77, 78, 2, 79, 82, 1, 83, 84,
2014 & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
2015 & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2016 & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
2017 & 0, 0, 0, 1, 99,101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2018 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2019 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2020 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
2021 &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 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, 1,137,144, 1,145,152, 0, 0, 0, 0,
2024 & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
2025 &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2026 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
2027 &163,169, 1,170,176, 1,177,180, 0, 0, 0, 0, 0, 0, 0, 0,
2028 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2029 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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= 609, 780) /
2032 & 0, 0, 0, 0, 3,181,182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2033 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2034 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,183,184, 3,185,
2035 &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 0, 0, 0,
2036 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2037 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,195,203, 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, 1,204,216, 0, 0, 0, 3,217,217, 3,
2040 &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
2041 &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
2042 & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
2043 DATA (isec_linear(K),K= 1, 152) /
2044 & 11, 12, -12, 13, -14, 16, 11, -12,
2045 & 16, -213, 16, 0, -211, 16, 0, -323,
2046 & 16, 0, -13, 12, 0, 22, 22, 0,
2047 & 22, -11, 11, 22, 22, 0, 111, 22,
2048 & 22, 111, 111, 111, 211, -211, 111, 211,
2049 & -211, 22, 211, -211, 0, 111, 111, 0,
2050 & 211, 111, 0, 211, -211, 111, 211, -211,
2051 & 0, 111, 22, 0, 221, 211, -211, 221,
2052 & 111, 111, 211, -211, 22, 22, 22, 0,
2053 & 321, -321, 0, 130, 310, 0, 113, 111,
2054 & 0, 211, -211, 111, 221, 22, 0, 113,
2055 & 111, 0, -213, 211, 0, 213, -211, 0,
2056 & 211, -211, 0, 111, 111, 0, 113, 111,
2057 & 0, -213, 211, 0, 213, -211, 0, 311,
2058 & -313, 0, -311, 313, 0, 113, 211, -211,
2059 & -13, 12, 0, 211, 111, 0, 211, 211,
2060 & -211, 211, 111, 111, -13, 111, 12, -11,
2061 & 111, 12, 211, -211, 0, 111, 111, 0,
2062 & 111, 111, 111, 211, -211, 111, 211, 13/
2063 DATA (isec_linear(K),K= 153, 304) /
2064 & 12, 211, 11, 12, 321, 111, 0, 311,
2065 & 211, 0, 311, 111, 0, 321, -211, 0,
2066 & 311, 111, 0, 321, -211, 0, 321, 111,
2067 & 0, 311, 211, 0, 311, 111, 0, 321,
2068 & -211, 0, 313, 111, 0, 323, -211, 0,
2069 & 311, 113, 0, 321, -213, 0, 311, 223,
2070 & 0, 311, 221, 0, 321, 111, 0, 311,
2071 & 211, 0, 323, 111, 0, 313, 211, 0,
2072 & 321, 113, 0, 311, 213, 0, 321, 223,
2073 & 0, 321, 221, 0, -321, 211, 211, -311,
2074 & 211, 0, -321, 211, 0, -321, 211, 111,
2075 & 311, 211, -211, 311, 111, 0, 421, 111,
2076 & 0, 421, 22, 0, 421, 211, 0, 411,
2077 & 111, 0, 411, 22, 0, 221, 211, 0,
2078 & 321, -321, 321, 321, -311, 0, 431, 22,
2079 & 0, 431, 22, 0, 111, 111, 0, 211,
2080 & -211, 0, 22, 22, 0, -11, 11, 0,
2081 & -13, 13, 0, 211, -211, 111, 443, 211,
2082 & -211, 443, 111, 111, 443, 221, 0, 2212/
2083 DATA (isec_linear(K),K= 305, 456) /
2084 & 11, 12, 2112, 111, 0, 2212, -211, 0,
2085 & 2112, 111, 111, 2112, 211, -211, 1114, 211,
2086 & 0, 2114, 111, 0, 2214, -211, 0, 2112,
2087 & 113, 0, 2212, -213, 0, 2112, 221, 0,
2088 & 2212, 111, 0, 2112, 211, 0, 2212, 111,
2089 & 111, 2212, 211, -211, 2224, -211, 0, 2214,
2090 & 111, 0, 2114, 211, 0, 2212, 113, 0,
2091 & 2112, 213, 0, 2212, 221, 0, 2212, -211,
2092 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2093 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2094 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2095 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2096 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2097 & 2212, -211, 0, 2112, 111, 0, 2212, -213,
2098 & 0, 2112, 113, 0, 3122, 311, 0, 3212,
2099 & 311, 0, 3112, 321, 0, 2112, 221, 0,
2100 & 2212, 111, 0, 2112, 211, 0, 2212, 113,
2101 & 0, 2112, 213, 0, 3122, 321, 0, 3222,
2102 & 311, 0, 3212, 321, 0, 2212, 221, 0/
2103 DATA (isec_linear(K),K= 457, 608) /
2104 & 2112, -211, 0, 2212, -211, 0, 2112, 111,
2105 & 0, 2212, 111, 0, 2112, 211, 0, 2212,
2106 & 211, 0, 2112, -211, 0, 2114, -211, 0,
2107 & 1114, 111, 0, 2112, -213, 0, 2212, -211,
2108 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2109 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2110 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2111 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2112 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2113 & 2212, 211, 0, 2224, 111, 0, 2214, 211,
2114 & 0, 2212, 213, 0, 2212, -211, 0, 2112,
2115 & 111, 0, 2212, 111, 0, 2112, 211, 0,
2116 & 3122, 22, 0, 2112, -211, 0, 3122, 211,
2117 & 0, 3212, 211, 0, 3222, 111, 0, 3122,
2118 & 111, 0, 3222, -211, 0, 3112, 211, 0,
2119 & 3122, -211, 0, 3212, -211, 0, 2112, -311,
2120 & 0, 2212, -321, 0, 3222, -211, 0, 3212,
2121 & 111, 0, 3112, 211, 0, 3122, 221, 0,
2122 & 3224, -211, 0, 3114, 211, 0, 3214, 111/
2123 DATA (isec_linear(K),K= 609, 760) /
2124 & 0, 2112, -311, 0, 2212, -321, 0, 3122,
2125 & 111, 0, 3122, 223, 0, 3122, 113, 0,
2126 & 3222, -213, 0, 3112, 213, 0, 3212, 113,
2127 & 0, 3122, 221, 0, 3212, 221, 0, 3222,
2128 & -211, 0, 3112, 211, 0, 3212, 111, 0,
2129 & 3122, 111, 0, 3122, -211, 0, 3322, 111,
2130 & 0, 3312, 211, 0, 3322, -211, 0, 3312,
2131 & 111, 0, 3322, -211, 0, 3312, 111, 0,
2132 & 3122, -321, 0, 3222, 221, 0, 3222, 331,
2133 & 0, 2212, -311, 0, 3322, 321, 0, 3224,
2134 & 221, 0, 2214, 331, 0, 2224, -321, 0,
2135 & 3122, 213, 0, 3212, 213, 0, 3222, 113,
2136 & 0, 3222, 223, 0, 2212, -313, 0, 2214,
2137 & -313, 0, 2224, -323, 0, 4122, 211, 0,
2138 & 4122, 111, 0, 4122, -211, 0, 3222, -311,
2139 & 0, 3322, 211, 0, 3222, -313, 0, 3322,
2140 & 213, 0, 3212, -313, 0, 3222, -323, 0,
2141 & 3322, 223, 0, 3312, 213, 0, 3214, -313,
2142 & 0, 3322, -311, 0, 3322, 313, 0, 3334/
2143 DATA (isec_linear(K),K= 761, 765) /
2144 & 213, 0, 3334, 211, 0/
2145 DATA (wg_chan(K),K= 1, 114) /
2146 &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
2147 &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
2148 &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
2149 &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
2150 &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
2151 &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
2152 &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
2153 &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
2154 &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
2155 &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
2156 &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
2157 &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
2158 &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
2159 &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
2160 &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
2161 &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
2162 &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
2163 &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
2164 &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
2165 DATA (wg_chan(K),K= 115, 228) /
2166 &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
2167 &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
2168 &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
2169 &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
2170 &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
2171 &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
2172 &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
2173 &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
2174 &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
2175 &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
2176 &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
2177 &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
2178 &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
2179 &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
2180 &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
2181 &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
2182 &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
2183 &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
2184 &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
2185 DATA (wg_chan(K),K= 229, 255) /
2186 &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
2187 &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
2188 &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
2189 &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
2190 &2.0000E-01,3.6000E-01,7.0000E-02/
2191 DATA (id_psm_linear(K),K= 1, 36) /
2192 & 111, 211, -311, 411, 0, 0, -211, 111,
2193 & -321, 421, 0, 0, 311, 321, 221, 431,
2194 & 0, 0, -411, -421, -431, 441, 0, 0,
2195 & 0, 0, 0, 0, 0, 0, 0, 0,
2196 & 0, 0, 0, 0/
2197 DATA (id_vem_linear(K),K= 1, 36) /
2198 & 113, 213, -313, 413, 0, 0, -213, 113,
2199 & -323, 423, 0, 0, 313, 323, 333, 433,
2200 & 0, 0, -413, -423, -433, 20443, 0, 0,
2201 & 0, 0, 0, 0, 0, 0, 0, 0,
2202 & 0, 0, 0, 0/
2203 DATA (id_b8_linear(K),K= 1, 171) /
2204 & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
2205 & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
2206 & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
2207 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2208 & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
2209 & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
2210 & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
2211 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2212 & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
2213 & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
2214 & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
2215 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2216 & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
2217 & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
2218 & 4412, 4422, 4432, 4444, 0, 0, 0, 0, 0,
2219 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2220 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2221 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2222 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2223 DATA (id_b8_linear(K),K= 172, 216) /
2224 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2225 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2226 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2227 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2228 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2229 DATA (id_b10_linear(K),K= 1, 171) /
2230 & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
2231 & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
2232 & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
2233 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2234 & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
2235 & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
2236 & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
2237 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2238 & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
2239 & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
2240 & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
2241 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2242 & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
2243 & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
2244 & 4414, 4424, 4434, 4444, 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= 172, 216) /
2250 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2251 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2252 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2253 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2254 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2255
2256 ID_pdg_max = i_tab_max
2257
2258C copy from local to global variables
2259 do i=1,i_tab_max
2260 ID_pdg_list(i) = number(i)
2261 name_list(i) = name(i)
2262 xm_list(i) = xmass(i)
2263 gam_list(i) = gamma(i)
2264 ich3_list(i) = ich3(i)
2265 iba3_list(i) = iba3(i)
2266 do j=1,3
2267 iq_list(j,i) = iq_linear(3*(i-1)+j)
2268 idec_list(j,i) = idec_linear(3*(i-1)+j)
2269 enddo
2270 enddo
2271
2272C initialize hash table
2273 call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
2274
2275 itmp = IDEB(71)
2276 IDEB(71) = -1
2277
2278C quark index table for mesons
2279 do i=1,6
2280 do j=1,6
2281 id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
2282 id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
2283 enddo
2284 enddo
2285
2286C quark index table for baryons
2287 do i=1,6
2288 do j=1,6
2289 do k=1,6
2290 id_b8_list(i,j,k) =
2291 & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
2292 id_b10_list(i,j,k) =
2293 & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
2294 enddo
2295 enddo
2296 enddo
2297
2298 IDEB(71) = itmp
2299
2300C copy secondary particles
2301C (translate PDG-ID to CPC and sort according to CPC)
2302 ichan = 0
2303 do i=1,i_tab_max
2304 if(idec_list(1,i).ne.0) then
2305 do j=idec_list(2,i),idec_list(3,i)
2306 ichan = ichan+1
2307 wg_sec_list(ichan) = wg_chan(j)
2308 do k=1,3
2309 if(isec_linear(3*(j-1)+k).ne.0) then
2310 isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
2311 else
2312 isec_list(k,ichan) = 0
2313 endif
2314 enddo
2315 enddo
2316 endif
2317 enddo
2318
2319C add two-pion background (low-mass photon dissociation)
2320 i = ipho_pdg2id(92)
2321 ichan = ichan+1
2322 idec_list(1,i) = 1
2323 idec_list(2,i) = ichan
2324 idec_list(3,i) = ichan
2325 wg_sec_list(ichan) = 1.D0
2326 isec_list(1,ichan) = ipho_pdg2id(211)
2327 isec_list(2,ichan) = ipho_pdg2id(-211)
2328 isec_list(3,ichan) = 0
2329
2330C min. mass limits for strings: q-qbar
2331 do i=1,6
2332 do j=1,6
2333 AM2P = 1000.D0
2334 AM2V = 1000.D0
2335 do k=1,3
2336C pseudo-scalar mesons
2337 i1 = iabs(id_psm_list(i,k))
2338 if(i1.ne.0) then
2339 AM1 = xm_list(i1)
2340 else
2341 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2342 endif
2343 i2 = iabs(id_psm_list(k,j))
2344 if(i2.ne.0) then
2345 AM2 = xm_list(i2)
2346 else
2347 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2348 endif
2349 AM2P = MIN(AM2P,AM1+AM2)
2350C vector mesons
2351 i1 = iabs(id_vem_list(i,k))
2352 if(i1.ne.0) then
2353 AM1 = xm_list(i1)
2354 else
2355 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2356 endif
2357 i2 = iabs(id_vem_list(k,j))
2358 if(i2.ne.0) then
2359 AM2 = xm_list(i2)
2360 else
2361 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2362 endif
2363 AM2V = MIN(AM2V,AM1+AM2)
2364 enddo
2365 xm_psm2_list(i,j) = AM2P
2366 xm_vem2_list(i,j) = AM2V
2367 enddo
2368 enddo
2369
2370C min. mass limits for strings: qq-q
2371 do i=1,6
2372 do j=1,6
2373 do k=1,6
2374 AM82 = 1000.D0
2375 AM102 = 1000.D0
2376 do l=1,3
2377C pseudo-scalar meson
2378 i1 = iabs(id_psm_list(k,l))
2379 if(i1.ne.0) then
2380 AM1 = xm_list(i1)
2381 else
2382 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2383 endif
2384C vector meson
2385 i2 = iabs(id_vem_list(k,l))
2386 if(i2.ne.0) then
2387 AM2 = xm_list(i2)
2388 else
2389 AM2 = pho_pmass(i,3)+pho_pmass(k,3)
2390 endif
2391C octet baryon
2392 AMM = min(AM1,AM2)
2393 K8 = id_b8_list(i,j,l)
2394 if(K8.ne.0) then
2395 AM1 = xm_list(K8)
2396 else
2397 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2398 endif
2399 AM82 = MIN(AM82, AM1 + AMM)
2400C decuplet baryon
2401 K10 = id_b10_list(i,j,l)
2402 if(K10.ne.0) then
2403 AM2 = xm_list(K10)
2404 else
2405 AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2406 endif
2407 AM102 = MIN(AM102, AM2 + AMM)
2408 enddo
2409 xm_b82_list(i,j,k) = AM82
2410 xm_b102_list(i,j,k) = AM102
2411 enddo
2412 enddo
2413 enddo
2414
2415C min. mass limits for strings: qq-qbarqbar
2416 do i=1,6
2417 do j=1,6
2418 do ii=1,6
2419 do jj=1,6
2420 AM82 = 1000.D0
2421 AM102 = 1000.D0
2422 do l=1,3
2423C octet baryons
2424 K8 = id_b8_list(i,j,l)
2425 if(K8.ne.0) then
2426 AM1 = xm_list(K8)
2427 else
2428 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2429 endif
2430 L8 = id_b8_list(ii,jj,l)
2431 if(L8.ne.0) then
2432 AM2 = xm_list(L8)
2433 else
2434 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2435 endif
2436 AM82 = MIN(AM82, AM1+AM2)
2437C decuplet baryons
2438 K10 = id_b10_list(i,j,l)
2439 if(K10.ne.0) then
2440 AM1 = xm_list(K10)
2441 else
2442 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2443 endif
2444 L10 = id_b10_list(ii,jj,l)
2445 if(L10.ne.0) then
2446 AM2 = xm_list(L10)
2447 else
2448 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2449 endif
2450 AM102 = MIN(AM102, AM1+AM2)
2451 enddo
2452 xm_bb82_list(i,j,ii,jj) = AM82
2453 xm_bb102_list(i,j,ii,jj) = AM102
2454 enddo
2455 enddo
2456 enddo
2457 enddo
2458
2459 END
2460
2461*$ CREATE PHO_PRESEL.FOR
2462*COPY PHO_PRESEL
2463CDECK ID>, PHO_PRESEL
2464 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2465C**********************************************************************
2466C
2467C user specific function to pre-select events during generation
2468C
2469C input: MODE 5 electron and photon kinematics
2470C 10 process and number of cut Pomerons
2471C 15 partons without construction of strings
2472C 20 partons assigned to strings
2473C 25 after fragmentation, complete final state
2474C
2475C output: IREJ 0 event accepted
2476C 50 event rejected
2477C
2478C**********************************************************************
2479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2480 SAVE
2481
2482C input/output channels
2483 INTEGER LI,LO
2484 COMMON /POINOU/ LI,LO
2485C event debugging information
2486 INTEGER NMAXD
2487 PARAMETER (NMAXD=100)
2488 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2489 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2490 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2491 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2492C standard particle data interface
2493 INTEGER NMXHEP
2494 PARAMETER (NMXHEP=4000)
2495 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2496 DOUBLE PRECISION PHEP,VHEP
2497 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2498 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2499 & VHEP(4,NMXHEP)
2500C extension to standard particle data interface (PHOJET specific)
2501 INTEGER IMPART,IPHIST,ICOLOR
2502 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2503C global event kinematics and particle IDs
2504 INTEGER IFPAP,IFPAB
2505 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2506 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2507C gamma-lepton or gamma-hadron vertex information
2508 INTEGER IGHEL,IDPSRC,IDBSRC
2509 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2510 & RADSRC,AMSRC,GAMSRC
2511 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2512 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2513 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2514C hard scattering data
2515 INTEGER MSCAHD
2516 PARAMETER ( MSCAHD = 50 )
2517 INTEGER LSCAHD,LSC1HD,LSIDX,
2518 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2519 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2520 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2521 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2522 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2523 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2524 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2525 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2526 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2527C event weights and generated cross section
2528 INTEGER IPOWGC,ISWCUT,IVWGHT
2529 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2530 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2531 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2532
2533 IREJ = 0
2534
2535* XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2536* IF(XBJ.LT.0.002D0) IREJ = 1
2537
2538 END
2539
2540*$ CREATE PHO_FIXCOL.FOR
2541*COPY PHO_FIXCOL
2542CDECK ID>, PHO_FIXCOL
2543 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2544C**********************************************************************
2545C
2546C interface to call PHOJET (fixed energy run) with
2547C collider kinematics
2548C
2549C equivalen photon approximation to get photon flux
2550C
2551C input: NEV number of events to generate
2552C THETA azimuthal angle (micro radians)
2553C PHI beam crossing angle
2554C (with respect to x, in degrees)
2555C E1 energy of particle 1 (+z direction, GeV)
2556C E2 energy of particle 2 (-z direction, GeV)
2557C
2558C note: particle types have to be specified before
2559C with PHO_SETPAR
2560C
2561C**********************************************************************
2562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2563 SAVE
2564
2565 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2566
2567C input/output channels
2568 INTEGER LI,LO
2569 COMMON /POINOU/ LI,LO
2570C event debugging information
2571 INTEGER NMAXD
2572 PARAMETER (NMAXD=100)
2573 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2574 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2575 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2576 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2577C general process information
2578 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2579 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2580C global event kinematics and particle IDs
2581 INTEGER IFPAP,IFPAB
2582 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2583 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2584C model switches and parameters
2585 CHARACTER*8 MDLNA
2586 INTEGER ISWMDL,IPAMDL
2587 DOUBLE PRECISION PARMDL
2588 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2589C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2590 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2591 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2592 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2593 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2594C integration precision for hard cross sections (obsolete)
2595 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2596 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2597C event weights and generated cross section
2598 INTEGER IPOWGC,ISWCUT,IVWGHT
2599 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2600 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2601 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2602
2603 DIMENSION P1(4),P2(4)
2604
2605C remnant initialization (only needed for DPMJET)
2606 ISAVP1 = IFPAP(1)
2607 ISAVB1 = IFPAB(1)
2608 IF(IFPAP(1).EQ.81) THEN
2609 IFPAP(1) = IDEQP(1)
2610 IFPAB(1) = IDEQB(1)
2611 ENDIF
2612 ISAVP2 = IFPAP(2)
2613 ISAVB2 = IFPAB(2)
2614 IF(IFPAP(2).EQ.82) THEN
2615 IFPAP(2) = IDEQP(2)
2616 IFPAB(2) = IDEQB(2)
2617 ENDIF
2618 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2619 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2620 PP1 = SQRT(E1**2-PMASS1**2)
2621 PP2 = SQRT(E2**2-PMASS2**2)
2622C beam crossing angle
2623 TH = 1.D-6*THETA/2.D0
2624 PH = PHI*BOG
2625 P1(1) = PP1*SIN(TH)*COS(PH)
2626 P1(2) = PP1*SIN(TH)*SIN(PH)
2627 P1(3) = PP1*COS(TH)
2628 P1(4) = E1
2629 P2(1) = PP2*SIN(TH)*COS(PH)
2630 P2(2) = PP2*SIN(TH)*SIN(PH)
2631 P2(3) = -PP2*COS(TH)
2632 P2(4) = E2
2633 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2634 IFPAP(1) = ISAVP1
2635 IFPAB(1) = ISAVB1
2636 IFPAP(2) = ISAVP2
2637 IFPAB(2) = ISAVB2
2638 ITRY = 0
2639 CALL PHO_PHIST(-1,SIGMAX)
2640 CALL PHO_LHIST(-1,SIGMAX)
2641C test of DPMJET interface (default is IPAMDL(13)=0)
2642 if(IPAMDL(13).gt.0) then
2643 MODE = IPAMDL(13)
2644 IPAMDL(13) = 0
2645 else
2646 MODE = 1
2647 endif
2648C main generation loop
2649 DO 50 I=1,NEV
2650 55 CONTINUE
2651 ITRY = ITRY+1
2652 CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2653 IF(IREJ.NE.0) GOTO 55
2654 CALL PHO_PHIST(1,HSWGHT(0))
2655 CALL PHO_LHIST(1,HSWGHT(0))
2656 50 CONTINUE
2657
2658 IF(NEV.GT.0) THEN
2659 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2660 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2661 & '=========================================================',
2662 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2663 & '========================================================='
2664 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2665 CALL PHO_PHIST(-2,SIGMAX)
2666 CALL PHO_LHIST(-2,SIGMAX)
2667 ELSE
2668 WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2669 ENDIF
2670
2671 END
2672
2673*$ CREATE PHO_FIXLAB.FOR
2674*COPY PHO_FIXLAB
2675CDECK ID>, PHO_FIXLAB
2676 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2677C**********************************************************************
2678C
2679C interface to call PHOJET (fixed energy run) with
2680C LAB kinematics (second particle as target)
2681C
2682C equivalent photon approximation to get photon flux
2683C
2684C input: NEV number of events to generate
2685C PLAB LAB momentum of particle 1
2686C
2687C note: particle types have to be specified before
2688C with PHO_SETPAR
2689C
2690C**********************************************************************
2691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2692 SAVE
2693
2694C input/output channels
2695 INTEGER LI,LO
2696 COMMON /POINOU/ LI,LO
2697C event debugging information
2698 INTEGER NMAXD
2699 PARAMETER (NMAXD=100)
2700 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2701 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2702 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2703 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2704C general process information
2705 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2706 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2707C global event kinematics and particle IDs
2708 INTEGER IFPAP,IFPAB
2709 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2710 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2711C model switches and parameters
2712 CHARACTER*8 MDLNA
2713 INTEGER ISWMDL,IPAMDL
2714 DOUBLE PRECISION PARMDL
2715 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2716C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2717 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2718 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2719 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2720 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2721C integration precision for hard cross sections (obsolete)
2722 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2723 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2724C event weights and generated cross section
2725 INTEGER IPOWGC,ISWCUT,IVWGHT
2726 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2727 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2728 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2729
2730 DIMENSION P1(4),P2(4)
2731
2732C remnant initialization (only needed for DPMJET)
2733 SPCM = PLAB
2734 ISAVP1 = IFPAP(1)
2735 ISAVB1 = IFPAB(1)
2736 IF(IFPAP(1).EQ.81) THEN
2737 IFPAP(1) = IDEQP(1)
2738 IFPAB(1) = IDEQB(1)
2739 ENDIF
2740 ISAVP2 = IFPAP(2)
2741 ISAVB2 = IFPAB(2)
2742 IF(IFPAP(2).EQ.82) THEN
2743 IFPAP(2) = IDEQP(2)
2744 IFPAB(2) = IDEQB(2)
2745 ENDIF
2746C get momenta in LAB system
2747 PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2748 PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2749 IF(PMASS2.LT.0.1D0) THEN
2750 WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2751 & 'no LAB system possible',IFPAB(1),IFPAB(2)
2752 ELSE
2753 P1(1) = 0.D0
2754 P1(2) = 0.D0
2755 P1(3) = PLAB
2756 P1(4) = SQRT(PMASS1+PLAB**2)
2757 P2(1) = 0.D0
2758 P2(2) = 0.D0
2759 P2(3) = 0.D0
2760 P2(4) = SQRT(PMASS2)
2761 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2762 IFPAP(1) = ISAVP1
2763 IFPAB(1) = ISAVB1
2764 IFPAP(2) = ISAVP2
2765 IFPAB(2) = ISAVB2
2766 ITRY = 0
2767 CALL PHO_PHIST(-1,SIGMAX)
2768 CALL PHO_LHIST(-1,SIGMAX)
2769C event generation loop
2770 DO 40 I=1,NEV
2771 45 CONTINUE
2772 ITRY = ITRY+1
2773 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2774 IF(IREJ.NE.0) GOTO 45
2775 CALL PHO_LHIST(1,HSWGHT(0))
2776 CALL PHO_PHIST(10,HSWGHT(0))
2777 40 CONTINUE
2778 IF(NEV.GT.0) THEN
2779 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2780 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2781 & '=========================================================',
2782 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2783 & '========================================================='
2784 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2785 CALL PHO_PHIST(-2,SIGMAX)
2786 CALL PHO_LHIST(-2,SIGMAX)
2787 ELSE
2788 WRITE(LO,'(1X,A,I5)')
2789 & 'PHO_FIXLAB: no events simulated',NEV
2790 ENDIF
2791 ENDIF
2792
2793 END
2794
2795*$ CREATE PHO_GPHERA.FOR
2796*COPY PHO_GPHERA
2797CDECK ID>, PHO_GPHERA
2798 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2799C**********************************************************************
2800C
2801C interface to call PHOJET (variable energy run) with
2802C HERA kinematics, photon as particle 2
2803C
2804C equivalent photon approximation to get photon flux
2805C
2806C input: NEVENT number of events to generate
2807C EE1 proton energy (LAB system)
2808C EE2 electron energy (LAB system)
2809C from /POFCUT/:
2810C YMIN2 lower limit of Y
2811C (energy fraction taken by photon from electron)
2812C YMAX2 upper limit of Y
2813C Q2MIN2 lower limit of photon virtuality
2814C Q2MAX2 upper limit of photon virtuality
2815C
2816C**********************************************************************
2817 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2818 SAVE
2819
2820 PARAMETER ( DEPS = 1.D-10,
2821 & PI = 3.14159265359D0 )
2822
2823C input/output channels
2824 INTEGER LI,LO
2825 COMMON /POINOU/ LI,LO
2826C event debugging information
2827 INTEGER NMAXD
2828 PARAMETER (NMAXD=100)
2829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2833C model switches and parameters
2834 CHARACTER*8 MDLNA
2835 INTEGER ISWMDL,IPAMDL
2836 DOUBLE PRECISION PARMDL
2837 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2838C photon flux kinematics and cuts
2839 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2840 & YMIN1,YMAX1,YMIN2,YMAX2,
2841 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2842 & THMIN1,THMAX1,THMIN2,THMAX2
2843 INTEGER ITAG1,ITAG2
2844 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2845 & YMIN1,YMAX1,YMIN2,YMAX2,
2846 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2847 & THMIN1,THMAX1,THMIN2,THMAX2,
2848 & ITAG1,ITAG2
2849C gamma-lepton or gamma-hadron vertex information
2850 INTEGER IGHEL,IDPSRC,IDBSRC
2851 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2852 & RADSRC,AMSRC,GAMSRC
2853 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2854 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2855 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2856C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2857 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2858 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2859 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2860 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2861C event weights and generated cross section
2862 INTEGER IPOWGC,ISWCUT,IVWGHT
2863 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2864 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2865 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2866
2867 DIMENSION P1(4),P2(4)
2868
2869 WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2870C assign particle momenta according to HERA kinematics
2871C proton data
2872 PROM = PHO_PMASS(2212,1)
2873 PROM2 = PROM**2
2874 IDPSRC(1) = 0
2875 IDBSRC(1) = 0
2876C electron data
2877 ELEM = 0.512D-03
2878 ELEM2 = ELEM**2
2879 AMSRC(2) = ELEM
2880 IDPSRC(2) = 11
2881 IDBSRC(2) = ipho_pdg2id(11)
2882C
2883 Q2MIN = Q2MIN2
2884 Q2MAX = Q2MAX2
2885C
2886 XIMAX = LOG(YMAX2)
2887 XIMIN = LOG(YMIN2)
2888 XIDEL = XIMAX-XIMIN
2889C
2890 IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2891 & WRITE(LO,'(/1X,A,1P2E11.4)')
2892 & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2893 & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2894C
2895 Max_tab = 50
2896 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2897 FLUXT = 0.D0
2898 FLUXL = 0.D0
2899 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2900 & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2901 DO 100 I=1,Max_tab
2902 Y = EXP(XIMIN+DELLY*DBLE(I-1))
2903 Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2904 FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2905 & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2906 FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2907 FLUXT = FLUXT + Y*FFT
2908 FLUXL = FLUXL + Y*FFL
2909 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2910 100 CONTINUE
2911 FLUXT = FLUXT*DELLY
2912 FLUXL = FLUXL*DELLY
2913 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2914 & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2915C
2916 AY = 0.D0
2917 AY2 = 0.D0
2918 YY = YMIN2
2919 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2920 WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2921 & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2922 IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2923C
2924C initialization of PHOJET at upper energy limit
2925C proton momentum
2926 P1(1) = 0.D0
2927 P1(2) = 0.D0
2928 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2929 P1(4) = EE1
2930C photon momentum
2931 EGAM = YMAX2*EE2
2932 P2(1) = 0.D0
2933 P2(2) = 0.D0
2934 P2(3) = -EGAM
2935 P2(4) = EGAM
2936C sum of both photon polarizations
2937 IGHEL(2) = -1
2938C
2939 CALL PHO_SETPAR(1,2212,0,0.D0)
2940 CALL PHO_SETPAR(2,22,0,0.D0)
2941 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2942 CALL PHO_PHIST(-1,SIGMAX)
2943 CALL PHO_LHIST(-1,SIGMAX)
2944C
2945C generation of events, flux calculation
2946 ECMIN2 = ECMIN**2
2947 ECMAX2 = ECMAX**2
2948 AY = 0.D0
2949 AY2 = 0.D0
2950 Q22MIN = 1.D30
2951 Q22AVE = 0.D0
2952 Q22AV2 = 0.D0
2953 Q22MAX = 0.D0
2954 AN2MIN = 1.D30
2955 AN2MAX = 0.D0
2956 YY2MIN = 1.D30
2957 YY2MAX = 0.D0
2958 NITER = NEVENT
2959 ITRY = 0
2960 ITRW = 0
2961 DO 200 I=1,NITER
2962 150 CONTINUE
2963C sample y
2964 ITRY = ITRY+1
2965 175 CONTINUE
2966 ITRW = ITRW+1
2967 YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2968 IF(ISWMDL(10).GE.2) THEN
2969 YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2970 ELSE
2971 YEFF = 1.D0+(1.D0-YY)**2
2972 ENDIF
2973 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2974 Q2LOG = LOG(Q2MAX/Q2LOW)
2975 WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
2976 IF(WGMAX.LT.WGH) THEN
2977 WRITE(LO,'(1X,A,3E12.5)')
2978 & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
2979 ENDIF
2980 IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
2981C sample Q2
2982 IF(IPAMDL(174).EQ.1) THEN
2983 185 CONTINUE
2984 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2985 WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
2986 IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
2987 ELSE
2988 Q2 = Q2LOW
2989 ENDIF
2990C
2991C incoming electron
2992 PINI(1,2) = 0.D0
2993 PINI(2,2) = 0.D0
2994 PINI(3,2) = -EE2
2995 PINI(4,2) = EE2
2996 PINI(5,2) = 0.D0
2997C outgoing electron
2998 YQ2 = SQRT((1.D0-YY)*Q2)
2999 Q2E = Q2/(4.D0*EE2)
3000 E1Y = EE2*(1.D0-YY)
3001 CALL PHO_SFECFE(SIF,COF)
3002 PFIN(1,2) = YQ2*COF
3003 PFIN(2,2) = YQ2*SIF
3004 PFIN(3,2) = -E1Y+Q2E
3005 PFIN(4,2) = E1Y+Q2E
3006 PFIN(5,2) = 0.D0
3007C set /POFSRC/
3008 GYY(2) = YY
3009 GQ2(2) = Q2
3010C polar angle
3011 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3012C electron tagger
3013 IF(PFIN(4,2).GT.EEMIN2) THEN
3014 IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3015 ENDIF
3016C azimuthal angle
3017 PFPHI(2) = ATAN2(COF,SIF)
3018C photon momentum
3019 P2(1) = -PFIN(1,2)
3020 P2(2) = -PFIN(2,2)
3021 P2(3) = PINI(3,2)-PFIN(3,2)
3022 P2(4) = PINI(4,2)-PFIN(4,2)
3023C proton momentum
3024 P1(1) = 0.D0
3025 P1(2) = 0.D0
3026 P1(3) = SQRT(EE1**2-PROM2)
3027 P1(4) = EE1
3028C ECMS cut
3029 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3030 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3031 IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3032 GGECM = SQRT(GGECM)
3033C
3034 PGAM(1,2) = P2(1)
3035 PGAM(2,2) = P2(2)
3036 PGAM(3,2) = P2(3)
3037 PGAM(4,2) = P2(4)
3038 PGAM(5,2) = -SQRT(Q2)
3039C photon helicity
3040 IF(ISWMDL(10).GE.2) THEN
3041 WGH = YEFF-2.D0*ELEM2*YY**2/Q2
3042 WGHL = 2.D0*(1-YY)
3043 IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3044 IGHEL(2) = 1
3045 ELSE
3046 IGHEL(2) = 0
3047 ENDIF
3048 ELSE
3049 IGHEL(2) = -1
3050 ENDIF
3051C user cuts
3052 CALL PHO_PRESEL(5,IREJ)
3053 IF(IREJ.NE.0) GOTO 175
3054C event generation
3055 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3056 IF(IREJ.NE.0) GOTO 150
3057C statistics
3058 AY = AY+YY
3059 AY2 = AY2+YY*YY
3060 YY2MIN = MIN(YY2MIN,YY)
3061 YY2MAX = MAX(YY2MAX,YY)
3062 Q22MIN = MIN(Q22MIN,Q2)
3063 Q22MAX = MAX(Q22MAX,Q2)
3064 Q22AVE = Q22AVE+Q2
3065 Q22AV2 = Q22AV2+Q2*Q2
3066 AN2MIN = MIN(AN2MIN,PFTHE(2))
3067 AN2MAX = MAX(AN2MAX,PFTHE(2))
3068C histograms
3069 CALL PHO_PHIST(1,HSWGHT(0))
3070 CALL PHO_LHIST(1,HSWGHT(0))
3071 200 CONTINUE
3072C
3073 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3074 WGY = WGY*LOG(YMAX2/YMIN2)
3075 AY = AY/DBLE(NITER)
3076 AY2 = AY2/DBLE(NITER)
3077 DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3078 Q22AVE = Q22AVE/DBLE(NITER)
3079 Q22AV2 = Q22AV2/DBLE(NITER)
3080 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3081 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3082C output of histograms
3083 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3084 &'=========================================================',
3085 &' ***** simulated cross section: ',WEIGHT,' mb *****',
3086 &'========================================================='
3087 WRITE(LO,'(//1X,A,3I10)')
3088 & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3089 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3090 & WGY,WEIGHT
3091 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
3092 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
3093 & YY2MIN,YY2MAX
3094 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
3095 & Q22AVE,Q22AV2
3096 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
3097 & Q22MIN,Q22MAX
3098 WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3099 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3100C
3101 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3102 IF(NITER.GT.1) THEN
3103 CALL PHO_PHIST(-2,WEIGHT)
3104 CALL PHO_LHIST(-2,WEIGHT)
3105 ELSE
3106 WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3107 ENDIF
3108
3109 END
3110
3111*$ CREATE PHO_GGEPEM.FOR
3112*COPY PHO_GGEPEM
3113CDECK ID>, PHO_GGEPEM
3114 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3115C**********************************************************************
3116C
3117C interface to call PHOJET (variable energy run) for
3118C gamma-gamma collisions on e+e- collider
3119C
3120C fully differential equivalent (improved) photon approximation
3121C to get photon flux
3122C
3123C input: EE1 LAB system energy of electron/positron 1
3124C EE2 LAB system energy of electron/positron 2
3125C NEVENT >0 number of events to generate
3126C -1 initialization
3127C -2 final call (cross section calculation)
3128C from /LEPCUT/:
3129C YMIN1 lower limit of Y1
3130C (energy fraction taken by photon from electron)
3131C YMAX1 upper limit of Y1
3132C Q2MIN1 lower limit of photon virtuality
3133C Q2MAX1 upper limit of photon virtuality
3134C THMIN1 lower limit of scattered electron
3135C THMAX1 upper limit of scattered electron
3136C YMIN2 lower limit of Y2
3137C (energy fraction taken by photon from electron)
3138C YMAX2 upper limit of Y2
3139C Q2MIN2 lower limit of photon virtuality
3140C Q2MAX2 upper limit of photon virtuality
3141C THMIN2 lower limit of scattered electron
3142C THMAX2 upper limit of scattered electron
3143C
3144C output: after final call with NEVENT=-2
3145C EE1 e+ e- cross section (mb)
3146C EE2 gamma-gamma cross section (mb)
3147C
3148C**********************************************************************
3149 IMPLICIT NONE
3150 SAVE
3151
3152 DOUBLE PRECISION EE1,EE2
3153 INTEGER NEVENT
3154
3155C input/output channels
3156 INTEGER LI,LO
3157 COMMON /POINOU/ LI,LO
3158C event debugging information
3159 INTEGER NMAXD
3160 PARAMETER (NMAXD=100)
3161 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3162 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3163 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3164 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3165C model switches and parameters
3166 CHARACTER*8 MDLNA
3167 INTEGER ISWMDL,IPAMDL
3168 DOUBLE PRECISION PARMDL
3169 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3170C some constants
3171 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3172 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3173 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3174C photon flux kinematics and cuts
3175 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3176 & YMIN1,YMAX1,YMIN2,YMAX2,
3177 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3178 & THMIN1,THMAX1,THMIN2,THMAX2
3179 INTEGER ITAG1,ITAG2
3180 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3181 & YMIN1,YMAX1,YMIN2,YMAX2,
3182 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3183 & THMIN1,THMAX1,THMIN2,THMAX2,
3184 & ITAG1,ITAG2
3185C gamma-lepton or gamma-hadron vertex information
3186 INTEGER IGHEL,IDPSRC,IDBSRC
3187 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3188 & RADSRC,AMSRC,GAMSRC
3189 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3190 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3191 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3192C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3193 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3194 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3195 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3196 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3197C event weights and generated cross section
3198 INTEGER IPOWGC,ISWCUT,IVWGHT
3199 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3200 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3201 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3202
3203C external functions
3204 DOUBLE PRECISION DT_RNDM
3205
3206C local variables
3207 DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3208 & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3209 & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3210 & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3211 & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3212 & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3213 & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3214 & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3215 & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3216
3217 INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3218 & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3219
3220 DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3221 integer ipho_pdg2id
3222
3223C initialization of event generation
3224
3225 if(NEVENT.eq.-1) then
3226
3227 DO 10 I=1,4
3228 IHETRY(I) = 0
3229 IHEAC1(I) = 0
3230 IHEAC2(I) = 0
3231 10 CONTINUE
3232
3233 WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3234
3235C electron data
3236 ELEM = 0.512D-03
3237 ELEM2 = ELEM**2
3238 AMSRC(1) = ELEM
3239 AMSRC(2) = ELEM
3240C lepton numbers
3241 IDPSRC(1) = 11
3242 IDPSRC(2) = -11
3243 IDBSRC(1) = ipho_pdg2id(11)
3244 IDBSRC(2) = ipho_pdg2id(-11)
3245
3246C check/update kinematic limitations
3247
3248 Ymi = min(Ymax1,1.D0-ELEM/EE1)
3249 if(Ymi.lt.Ymax1) then
3250 WRITE(LO,'(/1X,A,2E12.5)')
3251 & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3252 Ymax1 = YMI
3253 endif
3254 Ymi = min(Ymax2,1.D0-ELEM/EE2)
3255 if(Ymi.lt.Ymax2) then
3256 WRITE(LO,'(/1X,A,2E12.5)')
3257 & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3258 Ymax2 = YMI
3259 endif
3260
3261 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3262 IF(YMIN1.LT.YMI) THEN
3263 WRITE(LO,'(/1X,A,2E12.5)')
3264 & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3265 YMIN1 = YMI
3266 ELSE IF(YMIN1.GT.YMI) THEN
3267 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3268 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3269 & ' INSTEAD OF',YMIN1
3270 ENDIF
3271 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3272 IF(YMIN2.LT.YMI) THEN
3273 WRITE(LO,'(/1X,A,2E12.5)')
3274 & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3275 YMIN2 = YMI
3276 ELSE IF(YMIN2.GT.YMI) THEN
3277 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3278 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3279 & ' INSTEAD OF',YMIN2
3280 ENDIF
3281
3282C store COS of angular tagging range
3283 THMIC1 = COS(MAX(0.D0,THMIN1))
3284 THMAC1 = COS(MIN(THMAX1,PI))
3285 THMIC2 = COS(MAX(0.D0,THMIN2))
3286 THMAC2 = COS(MIN(THMAX2,PI))
3287
3288 X1MAX = LOG(YMAX1)
3289 X1MIN = LOG(YMIN1)
3290 X1DEL = X1MAX-X1MIN
3291 X2MAX = LOG(YMAX2)
3292 X2MIN = LOG(YMIN2)
3293 X2DEL = X2MAX-X2MIN
3294
3295C debug: integrated photon flux
3296
3297 if(IDEB(30).ge.1) then
3298 Max_tab = 50
3299 FLUXT = 0.D0
3300 FLUXL = 0.D0
3301 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3302 IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3303 & 'table of photon flux (trans/long side 1)',Max_tab
3304 do I=1,Max_tab
3305 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3306 if((1.D0-Y1).gt.1.D-8) then
3307 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3308 else
3309 Q2low1 = 2.D0*Q2max1
3310 endif
3311 if(Q2low1.lt.Q2max1) then
3312 FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3313 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3314 FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3315 else
3316 FFT = 0.D0
3317 FFL = 0.D0
3318 endif
3319 FLUXT = FLUXT + Y1*FFL
3320 FLUXL = FLUXL + Y1*FFT
3321 IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3322 enddo
3323 FLUXT = FLUXT*DELLY
3324 FLUXL = FLUXL*DELLY
3325 WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3326 & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
3327 endif
3328
3329C maximum weight
3330
3331 Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3332 Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3333 Y1 = YMIN1
3334 Y2 = YMIN2
3335 IF(ISWMDL(10).GE.2) THEN
3336C long. and transversely polarized photons
3337 WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3338 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3339 & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3340 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3341 ELSE
3342C transversely polarized photons only
3343 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3344 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3345 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3346 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3347 ENDIF
3348
3349C initialize gamma-gamma event generator
3350
3351C photon 1
3352 EGAM = YMAX1*EE1
3353 P1(1) = 0.D0
3354 P1(2) = 0.D0
3355 P1(3) = SQRT(EGAM**2-Q2LOW1)
3356 P1(4) = EGAM
3357C photon 2
3358 EGAM = YMAX2*EE2
3359 P2(1) = 0.D0
3360 P2(2) = 0.D0
3361 P2(3) = -SQRT(EGAM**2-Q2LOW2)
3362 P2(4) = EGAM
3363C sum of helicities
3364 IGHEL(1) = -1
3365 IGHEL(2) = -1
3366
3367C set min. energy for interpolation tables
3368 parmdl(19) = min(parmdl(19),ecmin)
3369
3370C initialize event gneration
3371 CALL PHO_SETPAR(1,22,0,0.D0)
3372 CALL PHO_SETPAR(2,22,0,0.D0)
3373 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3374 CALL PHO_PHIST(-1,SIGMAX)
3375 CALL PHO_LHIST(-1,SIGMAX)
3376
3377C generation of events, flux calculation
3378 ECMIN2 = ECMIN**2
3379 ECMAX2 = ECMAX**2
3380 ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3381 AY1 = 0.D0
3382 AY2 = 0.D0
3383 AYS1 = 0.D0
3384 AYS2 = 0.D0
3385 Q21MIN = 1.D30
3386 Q22MIN = 1.D30
3387 Q21MAX = 0.D0
3388 Q22MAX = 0.D0
3389 Q21AVE = 0.D0
3390 Q22AVE = 0.D0
3391 Q21AV2 = 0.D0
3392 Q22AV2 = 0.D0
3393 AN1MIN = 1.D30
3394 AN2MIN = 1.D30
3395 AN1MAX = 0.D0
3396 AN2MAX = 0.D0
3397 YY1MIN = 1.D30
3398 YY2MIN = 1.D30
3399 YY1MAX = 0.D0
3400 YY2MAX = 0.D0
3401 NITER = 0
3402 ITRY_low = 0
3403 ITRY_high = 0
3404 ITRW_low = 0
3405 ITRW_high = 0
3406
3407C generate NEVENT events (might be just 1 per call)
3408
3409 else if(NEVENT.gt.0) then
3410
3411 NITER = NITER+NEVENT
3412
3413 DO 200 I=1,NEVENT
3414
3415C sample y1, y2
3416 150 CONTINUE
3417 ITRY_low = ITRY_low+1
3418 if(ITRY_low.eq.1000000) then
3419 ITRY_low = 0
3420 ITRY_high = ITRY_high+1
3421 endif
3422
3423 175 CONTINUE
3424 ITRW_low = ITRW_low+1
3425 if(ITRW_low.eq.1000000) then
3426 ITRW_low = 0
3427 ITRW_high = ITRW_high+1
3428 endif
3429
3430 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3431 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3432 IF(Y1*Y2.LT.ECFRAC) GOTO 175
3433 IF(ISWMDL(10).GE.2) THEN
3434 YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3435 YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3436 ELSE
3437 YEFF1 = 1.D0+(1.D0-Y1)**2
3438 YEFF2 = 1.D0+(1.D0-Y2)**2
3439 ENDIF
3440
3441 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3442 Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3443 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3444 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3445 WGH = (YEFF1*Q2LOG1
3446 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3447 & *(YEFF2*Q2LOG2
3448 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3449 IF(WGMAX.LT.WGH) THEN
3450 WRITE(LO,'(1X,A,4E12.5)')
3451 & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3452 ENDIF
3453 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3454
3455C limit on Ecm_gg (app. cut, precise cut applied later)
3456 GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3457 if(GGECM2.lt.ECMIN2) goto 175
3458
3459C sample Q2
3460 IF(IPAMDL(174).EQ.1) THEN
3461 185 CONTINUE
3462 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3463 WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3464 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3465 ELSE
3466 Q2P1 = Q2LOW1
3467 ENDIF
3468
3469 IF(IPAMDL(174).EQ.1) THEN
3470 186 CONTINUE
3471 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3472 WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3473 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3474 ELSE
3475 Q2P2 = Q2LOW2
3476 ENDIF
3477
3478 GYY(1) = Y1
3479 GQ2(1) = Q2P1
3480 GYY(2) = Y2
3481 GQ2(2) = Q2P2
3482
3483C incoming electron 1
3484 PINI(1,1) = 0.D0
3485 PINI(2,1) = 0.D0
3486 PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3487 PINI(4,1) = EE1
3488 PINI(5,1) = ELEM
3489C photon 1
3490 PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3491 PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3492 & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3493 IF(PT2.LT.0.D0) GOTO 175
3494 PT = SQRT(PT2)
3495 CALL PHO_SFECFE(SIF1,COF1)
3496 P1(1) = COF1*PT
3497 P1(2) = SIF1*PT
3498 P1(3) = PP
3499 P1(4) = EE1*Y1
3500C outgoing electron 1
3501 PFIN(1,1) = -P1(1)
3502 PFIN(2,1) = -P1(2)
3503 PFIN(3,1) = PINI(3,1)-P1(3)
3504 PFIN(4,1) = PINI(4,1)-P1(4)
3505 PFIN(5,1) = ELEM
3506C incoming electron 2
3507 PINI(1,2) = 0.D0
3508 PINI(2,2) = 0.D0
3509 PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3510 PINI(4,2) = EE2
3511 PINI(5,2) = 0.D0
3512C photon 2
3513 PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3514 PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3515 & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3516 IF(PT2.LT.0.D0) GOTO 175
3517 PT = SQRT(PT2)
3518 CALL PHO_SFECFE(SIF2,COF2)
3519 P2(1) = COF2*PT
3520 P2(2) = SIF2*PT
3521 P2(3) = PP
3522 P2(4) = EE2*Y2
3523C outgoing electron 2
3524 PFIN(1,2) = -P2(1)
3525 PFIN(2,2) = -P2(2)
3526 PFIN(3,2) = PINI(3,2)-P2(3)
3527 PFIN(4,2) = PINI(4,2)-P2(4)
3528 PFIN(5,2) = ELEM
3529
3530C precise ECMS cut
3531
3532 GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3533 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3534 IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3535 GGECM = SQRT(GGECM2)
3536
3537C beam lepton detector acceptance
3538
3539C lepton tagger 1
3540 CPFTHE = PFIN(3,1)/PFIN(4,1)
3541 ITG1 = 0
3542 IF(PFIN(4,1).GE.EEMIN1) THEN
3543 IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3544 ENDIF
3545
3546C lepton tagger 2
3547 CPFTHE = PFIN(3,2)/PFIN(4,2)
3548 ITG2 = 0
3549 IF(PFIN(4,2).GE.EEMIN2) THEN
3550 IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3551 ENDIF
3552
3553C beam lepton taggers
3554
3555C anti-tag
3556 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3557 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3558C tag
3559 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3560 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3561C single-tag inclusive
3562 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3563 & GOTO 175
3564C single-tag/anti-tag
3565 IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3566 & GOTO 175
3567
3568 PGAM(1,1) = P1(1)
3569 PGAM(2,1) = P1(2)
3570 PGAM(3,1) = P1(3)
3571 PGAM(4,1) = P1(4)
3572 PGAM(5,1) = -SQRT(Q2P1)
3573 PGAM(1,2) = P2(1)
3574 PGAM(2,2) = P2(2)
3575 PGAM(3,2) = P2(3)
3576 PGAM(4,2) = P2(4)
3577 PGAM(5,2) = -SQRT(Q2P2)
3578
3579C photon helicities
3580 IF(ISWMDL(10).GE.2) THEN
3581 WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3582 WGHL = 2.D0*(1-Y1)
3583 IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3584 IGHEL(1) = 1
3585 ELSE
3586 IGHEL(1) = 0
3587 ENDIF
3588 WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3589 WGHL = 2.D0*(1-Y2)
3590 IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3591 IGHEL(2) = 1
3592 ELSE
3593 IGHEL(2) = 0
3594 ENDIF
3595 K = 2*IGHEL(1)+IGHEL(2)+1
3596 IHETRY(K) = IHETRY(K)+1
3597 ELSE
3598 IGHEL(1) = -1
3599 IGHEL(2) = -1
3600 ENDIF
3601
3602C user cuts
3603 CALL PHO_PRESEL(5,IREJ)
3604 IF(IREJ.NE.0) GOTO 175
3605
3606 WGFX = 1.D0
3607C reweight according to LO photon emission diagrams (Budnev et al.)
3608 IF(IPAMDL(116).GE.1) THEN
3609 CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3610 WGFX = FLXQPM/FLXAPP
3611 if(WGFX.gt.1.D0) then
3612 WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3613 & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3614 & Y1,Y2,Q2P1,Q2P2,GGECM
3615 endif
3616 ENDIF
3617
3618C event generation
3619* IVWGHT(1) = 1
3620* EVWGHT(1) = MAX(WGFX,1.D0)
3621 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3622 IF(IREJ.NE.0) GOTO 150
3623 IF(ISWMDL(10).GE.2) THEN
3624 K = 2*IGHEL(1)+IGHEL(2)+1
3625 IHEAC1(K) = IHEAC1(K)+1
3626 ENDIF
3627
3628C reweight according to QPM model (e+e- collider only)
3629 IF((KHDIR.GT.0).AND.
3630 & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3631 CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3632 WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3633 IF(DT_RNDM(WG).GT.WG) GOTO 150
3634 ELSE IF(IPAMDL(116).GE.1) THEN
3635 IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3636 ENDIF
3637
3638C polar angle
3639 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3640 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3641C azimuthal angle
3642 PFPHI(1) = ATAN2(COF1,SIF1)
3643 PFPHI(2) = ATAN2(COF2,SIF2)
3644
3645C statistics
3646 AY1 = AY1+Y1
3647 AYS1 = AYS1+Y1*Y1
3648 AY2 = AY2+Y2
3649 AYS2 = AYS2+Y2*Y2
3650 Q21MIN = MIN(Q21MIN,Q2P1)
3651 Q22MIN = MIN(Q22MIN,Q2P2)
3652 Q21MAX = MAX(Q21MAX,Q2P1)
3653 Q22MAX = MAX(Q22MAX,Q2P2)
3654 AN1MIN = MIN(AN1MIN,PFTHE(1))
3655 AN2MIN = MIN(AN2MIN,PFTHE(2))
3656 AN1MAX = MAX(AN1MAX,PFTHE(1))
3657 AN2MAX = MAX(AN2MAX,PFTHE(2))
3658 YY1MIN = MIN(YY1MIN,Y1)
3659 YY2MIN = MIN(YY2MIN,Y2)
3660 YY1MAX = MAX(YY1MAX,Y1)
3661 YY2MAX = MAX(YY2MAX,Y2)
3662 Q21AVE = Q21AVE+Q2P1
3663 Q22AVE = Q22AVE+Q2P2
3664 Q21AV2 = Q21AV2+Q2P1*Q2P1
3665 Q22AV2 = Q22AV2+Q2P2*Q2P2
3666 IF(ISWMDL(10).GE.2) THEN
3667 K = 2*IGHEL(1)+IGHEL(2)+1
3668 IHEAC2(K) = IHEAC2(K)+1
3669 ENDIF
3670C external histograms
3671 CALL PHO_PHIST(1,HSWGHT(0))
3672 CALL PHO_LHIST(1,HSWGHT(0))
3673 200 CONTINUE
3674
3675C final cross section calculation and event generation summary
3676
3677 else if(NEVENT.eq.-2) then
3678
3679* EVWGHT(1) = 1.D0
3680* IVWGHT(1) = 0
3681 DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3682 DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3683 WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3684 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3685 AY1 = AY1/DBLE(NITER)
3686 AYS1 = AYS1/DBLE(NITER)
3687 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3688 AY2 = AY2/DBLE(NITER)
3689 AYS2 = AYS2/DBLE(NITER)
3690 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3691 Q21AVE = Q21AVE/DBLE(NITER)
3692 Q21AV2 = Q21AV2/DBLE(NITER)
3693 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3694 Q22AVE = Q22AVE/DBLE(NITER)
3695 Q22AV2 = Q22AV2/DBLE(NITER)
3696 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3697 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3698 EE1 = WEIGHT
3699 EE2 = SIGMAX*DBLE(NITER)/DITRY
3700
3701C output of statistics, histograms
3702 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3703 & '=========================================================',
3704 & ' ***** simulated cross section: ',WEIGHT,' mb *****',
3705 & '========================================================='
3706 WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3707 & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3708 WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3709 & WGY,WEIGHT
3710 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
3711 & AY1,DAY1
3712 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
3713 & AY2,DAY2
3714 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
3715 & YY1MIN,YY1MAX
3716 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
3717 & YY2MIN,YY2MAX
3718 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
3719 & Q21AVE,Q21AV2
3720 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
3721 & Q21MIN,Q21MAX
3722 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
3723 & Q22AVE,Q22AV2
3724 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
3725 & Q22MIN,Q22MAX
3726 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3727 & AN1MIN,AN1MAX
3728 WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3729 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3730
3731 IF(ISWMDL(10).GE.2) THEN
3732 WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3733 & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
3734 & 'tried: ',IHETRY,
3735 & 'accepted (1): ',IHEAC1,
3736 & 'accepted (2): ',IHEAC2
3737 ENDIF
3738
3739 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3740 IF(NITER.GT.1) THEN
3741 CALL PHO_PHIST(-2,WEIGHT)
3742 CALL PHO_LHIST(-2,WEIGHT)
3743 ELSE
3744 WRITE(LO,'(1X,A,I4)')
3745 & 'PHO_GGEPEM: no output of histograms',NITER
3746 ENDIF
3747
3748 endif
3749
3750 END
3751
3752*$ CREATE PHO_WGEPEM.FOR
3753*COPY PHO_WGEPEM
3754CDECK ID>, PHO_WGEPEM
3755 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3756C**********************************************************************
3757C
3758C calculate cross section weights for
3759C fully differential equivalent (improved) photon approximation
3760C and/or
3761C fully differential QPM model with exact one-photon exchange graphs
3762C
3763C (unpolarized lepton beams)
3764C
3765C input: IMODE 0 flux calculation only
3766C 1 flux folded with QPM cross section
3767C /POFSRC/ photon and electron momenta
3768C /POPRCS/ process type
3769C /POCKIN/ kinematics of hard scattering
3770C
3771C output: WGHAPP weight of event according to approximation
3772C WGHQPM weight of event according to one-photon exchange
3773C
3774C**********************************************************************
3775 IMPLICIT NONE
3776 SAVE
3777
3778 DOUBLE PRECISION WGHAPP,WGHQPM
3779 INTEGER IMODE
3780
3781C input/output channels
3782 INTEGER LI,LO
3783 COMMON /POINOU/ LI,LO
3784C event debugging information
3785 INTEGER NMAXD
3786 PARAMETER (NMAXD=100)
3787 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3788 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3789 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3790 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3791C model switches and parameters
3792 CHARACTER*8 MDLNA
3793 INTEGER ISWMDL,IPAMDL
3794 DOUBLE PRECISION PARMDL
3795 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3796C some constants
3797 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3798 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3799 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3800C gamma-lepton or gamma-hadron vertex information
3801 INTEGER IGHEL,IDPSRC,IDBSRC
3802 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3803 & RADSRC,AMSRC,GAMSRC
3804 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3805 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3806 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3807C general process information
3808 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3809 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3810C data on most recent hard scattering
3811 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3812 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3813 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3814 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3815 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3816 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3817 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3818 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3819 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3820C hard scattering parameters used for most recent hard interaction
3821 INTEGER NFbeta,NF
3822 DOUBLE PRECISION ALQCD2,BQCD
3823 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3824C currently activated parton density parametrizations
3825 CHARACTER*8 PDFNAM
3826 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3827 DOUBLE PRECISION PDFLAM,PDFQ2M
3828 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3829 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3830C standard particle data interface
3831 INTEGER NMXHEP
3832 PARAMETER (NMXHEP=4000)
3833 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3834 DOUBLE PRECISION PHEP,VHEP
3835 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3836 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3837 & VHEP(4,NMXHEP)
3838C extension to standard particle data interface (PHOJET specific)
3839 INTEGER IMPART,IPHIST,ICOLOR
3840 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3841
3842 DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3843 & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3844 & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3845 & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3846 & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3847 & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3848 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3849
3850 INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3851
3852 DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3853 DIMENSION HELFLX(6),SIGQPM(6)
3854
3855 WGHAPP = 1.D0
3856 WGHQPM = 0.D0
3857
3858C strict pt cutoff after putting partons on mass shell,
3859C calculated in gamma-gamma CMS
3860 if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3861 if(PTfin.lt.PTwant) then
3862 if(ipamdl(121).gt.1) return
3863 if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3864 endif
3865 endif
3866
3867C cross section of sampled event (approximate treatment)
3868
3869C photon flux
3870 DO 50 K=1,2
3871 XM2(K) = AMSRC(K)**2
3872 IF(abs(IGHEL(K)).EQ.1) THEN
3873 WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3874 & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3875 ELSE
3876 WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3877 ENDIF
3878 50 CONTINUE
3879
3880 W2 = GGECM*GGECM
3881 IDIR = 0
3882 WGHQQ = 1.D0
3883
3884C direct or single-resolved gam-gam interaction
3885 IF((IMODE.GE.1).AND.
3886 & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3887 IDIR = 1
3888 WGHQQ = 0.D0
3889C determine final state partons
3890 DO 100 I=3,NHEP
3891 IF(ISTHEP(I).EQ.25) GOTO 110
3892 100 CONTINUE
3893 WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3894 & 'inconsistent process information (MSPR)',MSPR
3895 CALL PHO_ABORT
3896 110 CONTINUE
3897 IPOS = I
3898C final state flavors
3899 IPFL1 = ABS(IDHEP(IPOS+3))
3900 IPFL2 = ABS(IDHEP(IPOS+4))
3901 SH = X1*X2*W2
3902C calculate alpha-em
3903 ALPHA1 = pho_alphae(QQAL)
3904C calculate alpha-s
3905 IF(MSPR.LT.14) THEN
3906 ALPHA2 = PHO_ALPHAS(QQAL,3)
3907 ENDIF
3908C LO matrix element (8 pi s dsig/dt)
3909* QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3910 QC2 = Q_ch2(IPFL2)
3911 IF(IPFL2.EQ.0) THEN
3912 WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3913 & 'invalid hard process - flavor combination',
3914 & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3915 ENDIF
3916 IF(MSPR.EQ.10) THEN
3917 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3918 & *8.D0*PI*SH
3919 ELSE IF(MSPR.EQ.11) THEN
3920 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3921 & *8.D0*PI*SH
3922 ELSE IF(MSPR.EQ.12) THEN
3923 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3924 & *8.D0*PI*SH
3925 ELSE IF(MSPR.EQ.13) THEN
3926 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3927 & *8.D0*PI*SH
3928 ELSE IF(MSPR.EQ.14) THEN
3929 WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3930 & *8.D0*PI*SH
3931 ENDIF
3932 ENDIF
3933
3934C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3935 WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3936
3937C full leading-order QPM prediction (Budnev et al.)
3938
3939C full two-gamma flux
3940
3941 P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3942 & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3943 P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3944 & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3945 Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3946 & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3947 P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3948 & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3949 DO 120 I=1,4
3950 P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3951 P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3952 120 CONTINUE
3953 XTM1 = 2.D0*P1Q2-Q1Q2
3954 XTM2 = 2.D0*P2Q1-Q1Q2
3955 XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3956 XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3957 YCAP = P1P2**2-XM2(1)*XM2(2)
3958 CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3959
3960 RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3961 RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
3962 RHO100 = XTM1**2/XCAP-1.D0
3963 RHO200 = XTM2**2/XCAP-1.D0
3964 RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
3965 RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
3966 SS = 2.D0*P1P2+XM2(1)+XM2(2)
3967
3968 HELFLX(1) = 4.D0*RHO1PP*RHO2PP
3969 HELFLX(2) = RHOPM2
3970 HELFLX(3) = 2.D0*RHO1PP*RHO200
3971 HELFLX(4) = 2.D0*RHO100*RHO2PP
3972 HELFLX(5) = RHO100*RHO200
3973 HELFLX(6) = -RHOP08
3974
3975C only flux calculation
3976
3977 IF(IDIR.EQ.0) THEN
3978 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
3979 WEIGHT = HELFLX(1)
3980 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
3981 WEIGHT = HELFLX(3)
3982 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
3983 WEIGHT = HELFLX(4)
3984 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
3985 WEIGHT = HELFLX(5)
3986 ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
3987 WEIGHT = HELFLX(1)
3988 ELSE
3989 WRITE(LO,'(/1X,A,2I3)')
3990 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
3991 WRITE(LO,'(1X,A,I12)')
3992 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
3993 WEIGHT = 0.D0
3994 ENDIF
3995
3996C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3997 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
3998 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
3999
4000 ELSE
4001
4002C flux folded with cross section
4003C polarized, leading order gam gam --> q qbar cross sections
4004
4005 DO 125 I=1,6
4006 SIGQPM(I) = 0.D0
4007 125 CONTINUE
4008C momenta of produced parton pair
4009 I1 = IPOS+3
4010 I2 = IPOS+4
4011 DO 150 K=1,4
4012 XK1(K) = PHEP(K,I1)
4013 XK2(K) = PHEP(K,I2)
4014 150 CONTINUE
4015 XQ2 = PHEP(5,I2)**2
4016
4017 IF(MSPR.EQ.14) THEN
4018C direct photon-photon interaction
4019 XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4020 & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4021 & +(PGAM(3,1)-XK1(3))**2
4022 XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4023 & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4024 & +(PGAM(3,1)-XK2(3))**2
4025 CC = Q1Q2
4026 AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4027 BB = CC**2-XKAP*XKAM
4028 DD = CC**2-GQ2(1)*GQ2(2)
4029 RR = -XQ2+W2*AA/(4.D0*DD)
4030 Q1KK = Q1Q2-GQ2(1)
4031 Q2KK = Q1Q2-GQ2(2)
4032 FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4033
4034 ELSE
4035C single-resolved photon-hadron interactions
4036C Mandelstam variables
4037 IF(MSPR.LE.11) THEN
4038 TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4039 & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4040 UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4041 & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4042 ELSE
4043 TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4044 & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4045 UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4046 & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4047 ENDIF
4048 V = TH/SH
4049 U = UH/SH
4050 ENDIF
4051
4052 WEIGHT = 0.D0
4053 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4054 IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4055 IF(MSPR.EQ.10) THEN
4056 Q2 = -GQ2(1)
4057 SP = SH-XQ2
4058 TP = UH-XQ2
4059 ELSE
4060 Q2 = -GQ2(2)
4061 SP = SH-XQ2
4062 TP = TH-XQ2
4063 ENDIF
4064 SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4065 & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4066 & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4067 & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4068 & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4069 & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4070 & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4071 & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4072 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4073 ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4074 IF(MSPR.EQ.11) THEN
4075 Q2 = -GQ2(1)
4076 ELSE
4077 Q2 = -GQ2(2)
4078 ENDIF
4079 SP = SH
4080 TP = UH
4081 SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4082 & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4083 & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4084 & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4085 & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4086 & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4087 & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4088 & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4089 & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4090 & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4091 & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4092 & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4093 & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4094 & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4095 & (Q2-SP-TP+XQ2)**2)
4096 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4097 ELSE IF(MSPR.EQ.14) THEN
4098 SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4099 SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4100 SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4101 & -2.D0*XKAP*XKAM*AA
4102 SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4103 SIGQPM(2) = SWPPMM*FAC
4104 WEIGHT = HELFLX(1)*SIGQPM(1)
4105 & +HELFLX(2)*SIGQPM(2)
4106 ENDIF
4107 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4108 IF(MSPR.EQ.12) THEN
4109 Q2 = -GQ2(2)
4110 SP = SH-XQ2
4111 TP = TH-XQ2
4112 SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4113 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4114 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4115 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4116 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4117 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4118 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4119 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4120 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4121 ELSE IF(MSPR.EQ.13) THEN
4122 Q2 = -GQ2(2)
4123 SP = SH
4124 TP = TH
4125 SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4126 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4127 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4128 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4129 ELSE IF(MSPR.EQ.14) THEN
4130 SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4131 & -XKAP*XKAM*Q1KK**2)/DD
4132 SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4133 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4134 & *SQRT(GQ2(1)*GQ2(2))/DD
4135 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4136 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4137 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4138 & *SQRT(GQ2(1)*GQ2(2))/DD
4139 SIGQPM(3) = SWP0P0*FAC
4140 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4141 WEIGHT = HELFLX(3)*SIGQPM(3)
4142 & +HELFLX(6)*SIGQPM(6)/2.D0
4143 ENDIF
4144 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4145 IF(MSPR.EQ.10) THEN
4146 Q2 = -GQ2(1)
4147 SP = SH-XQ2
4148 TP = UH-XQ2
4149 SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4150 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4151 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4152 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4153 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4154 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4155 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4156 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4157 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4158 ELSE IF(MSPR.EQ.11) THEN
4159 Q2 = -GQ2(1)
4160 SP = SH
4161 TP = TH
4162 SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4163 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4164 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4165 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4166 ELSE IF(MSPR.EQ.14) THEN
4167 SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4168 & -XKAP*XKAM*Q2KK**2)/DD
4169 SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4170 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4171 & *SQRT(GQ2(1)*GQ2(2))/DD
4172 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4173 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4174 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4175 & *SQRT(GQ2(1)*GQ2(2))/DD
4176 SIGQPM(4) = SW0P0P*FAC
4177 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4178 WEIGHT = HELFLX(4)*SIGQPM(4)
4179 & +HELFLX(6)*SIGQPM(6)/2.D0
4180 ENDIF
4181 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4182 IF(MSPR.EQ.14) THEN
4183 SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4184 SIGQPM(5) = SW0000*FAC
4185 WEIGHT = HELFLX(5)*SIGQPM(5)
4186 ENDIF
4187 ELSE
4188 WRITE(LO,'(/1X,A,2I3)')
4189 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4190 WRITE(LO,'(1X,A,I12)')
4191 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4192 WEIGHT = 0.D0
4193 ENDIF
4194
4195C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4196
4197 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4198 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4199
4200 ENDIF
4201
4202 END
4203
4204*$ CREATE PHO_GGBLSR.FOR
4205*COPY PHO_GGBLSR
4206CDECK ID>, PHO_GGBLSR
4207 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4208 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4209C***********************************************************************
4210C
4211C interface to call PHOJET (variable energy run) for
4212C gamma-gamma collisions via laser backscattering
4213C
4214C input: EE1 lab. system energy of electron/positron 1
4215C EE2 lab. system energy of electron/positron 2
4216C NEVENT number of events to generate
4217C Pl_lam_1/2 product of electron and photon pol.
4218C X_1/2 standard X parameter
4219C rho ratio of distance to conversion point and
4220C transverse beam size
4221C A ellipticity of electon beam
4222C
4223C (see Ginzburg & Kotkin hep-ph/9905462)
4224C
4225C from /LEPCUT/:
4226C YMIN1 lower limit of Y1
4227C (energy fraction taken by photon from electron)
4228C YMAX1 upper limit of Y1
4229C YMIN2 lower limit of Y2
4230C (energy fraction taken by photon from electron)
4231C YMAX2 upper limit of Y2
4232C
4233C***********************************************************************
4234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4235 SAVE
4236
4237 PARAMETER ( PI = 3.14159265359D0 )
4238
4239C input/output channels
4240 INTEGER LI,LO
4241 COMMON /POINOU/ LI,LO
4242C event debugging information
4243 INTEGER NMAXD
4244 PARAMETER (NMAXD=100)
4245 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4246 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4248 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4249C photon flux kinematics and cuts
4250 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4251 & YMIN1,YMAX1,YMIN2,YMAX2,
4252 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4253 & THMIN1,THMAX1,THMIN2,THMAX2
4254 INTEGER ITAG1,ITAG2
4255 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4256 & YMIN1,YMAX1,YMIN2,YMAX2,
4257 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4258 & THMIN1,THMAX1,THMIN2,THMAX2,
4259 & ITAG1,ITAG2
4260C gamma-lepton or gamma-hadron vertex information
4261 INTEGER IGHEL,IDPSRC,IDBSRC
4262 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4263 & RADSRC,AMSRC,GAMSRC
4264 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4265 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4266 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4267C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4268 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4269 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4270 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4271 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4272C event weights and generated cross section
4273 INTEGER IPOWGC,ISWCUT,IVWGHT
4274 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4275 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4276 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4277
4278 parameter (N_dim=100)
4279 dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4280 & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4281 & Xgrid(96),Wgrid(96)
4282
4283 DIMENSION P1(4),P2(4)
4284
4285 Pi2 = 2.D0*Pi
4286
4287 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4288
4289 YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4290 YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4291 IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4292 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4293 & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
4294 RETURN
4295 ENDIF
4296 IDPSRC(1) = 0
4297 IDBSRC(1) = 0
4298 IDPSRC(2) = 0
4299 IDBSRC(2) = 0
4300
4301C initialize sampling
4302
4303 Max_tab = 50
4304 DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4305 DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4306
4307 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4308 & 'PHO_GGBLSR: table of photon flux ',Max_tab
4309
4310 DO 100 I=1,Max_tab
4311
4312 y1 = YMIN1+DELY1*DBLE(I-1)
4313 r1 = y1/(X_1*(1.D0-y1))
4314 X_inp_1(i) = y1
4315 F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4316 & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4317
4318 y2 = YMIN2+DELY2*DBLE(I-1)
4319 r2 = y2/(X_2*(1.D0-y2))
4320 X_inp_2(i) = y2
4321 F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4322 & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4323
4324 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4325 & y1,F_inp_1(i),y2,F_inp_2(i)
4326
4327 100 CONTINUE
4328
4329 call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4330 call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4331
4332C initialize event generator
4333
4334C photon 1
4335 EGAM = YMAX1*EE1
4336 P1(1) = 0.D0
4337 P1(2) = 0.D0
4338 P1(3) = EGAM
4339 P1(4) = EGAM
4340C photon 2
4341 EGAM = YMAX2*EE2
4342 P2(1) = 0.D0
4343 P2(2) = 0.D0
4344 P2(3) = -EGAM
4345 P2(4) = EGAM
4346 CALL PHO_SETPAR(1,22,0,0.D0)
4347 CALL PHO_SETPAR(2,22,0,0.D0)
4348 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4349 CALL PHO_PHIST(-1,SIGMAX)
4350 CALL PHO_LHIST(-1,SIGMAX)
4351
4352C generation of events
4353 AY1 = 0.D0
4354 AY2 = 0.D0
4355 AYS1 = 0.D0
4356 AYS2 = 0.D0
4357 NITER = NEVENT
4358 ITRY = 0
4359 ITRW = 0
4360 DO 200 I=1,NITER
4361 150 CONTINUE
4362 ITRY = ITRY+1
4363 175 CONTINUE
4364 ITRW = ITRW+1
4365
4366 call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4367 call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4368
4369 g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4370 g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4371 if(abs(1.D0-A).lt.1.D-3) then
4372 v = rho**2/4.D0*g_1*g_2
4373 Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4374 else
4375 Nint = 16
4376 call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4377 A2 = A**2
4378 fac = rho**2/(4.D0*(1.D0+A2))
4379 Wght = 0.D0
4380 do i1=1,Nint
4381 phi_1 = Xgrid(i1)
4382 do i2=1,Nint
4383 phi_2 = Xgrid(i2)
4384 Wght = Wght
4385 & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4386 & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4387 & *Wgrid(i1)*Wgrid(i2)
4388 enddo
4389 enddo
4390 Wght = Wght/Pi2**2
4391 endif
4392
4393 IF(Wght.GT.1.D0) THEN
4394 WRITE(LO,'(1X,A,5E11.4)')
4395 & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4396 ENDIF
4397 IF(DT_RNDM(dum).GT.Wght) GOTO 175
4398
4399 Y1 = X_out_1
4400 Y2 = X_out_2
4401
4402 Q2P1 = 0.D0
4403 Q2P2 = 0.D0
4404 GYY(1) = Y1
4405 GQ2(1) = Q2P1
4406 GYY(2) = Y2
4407 GQ2(2) = Q2P2
4408C incoming electron 1
4409 PINI(1,1) = 0.D0
4410 PINI(2,1) = 0.D0
4411 PINI(3,1) = EE1
4412 PINI(4,1) = EE1
4413 PINI(5,1) = 0.D0
4414C outgoing electron 1
4415 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4416 Q2E = Q2P1/(4.D0*EE1)
4417 E1Y = EE1*(1.D0-Y1)
4418 CALL PHO_SFECFE(SIF,COF)
4419 PFIN(1,1) = YQ2*COF
4420 PFIN(2,1) = YQ2*SIF
4421 PFIN(3,1) = E1Y-Q2E
4422 PFIN(4,1) = E1Y+Q2E
4423 PFIN(5,1) = 0.D0
4424C photon 1
4425 P1(1) = -PFIN(1,1)
4426 P1(2) = -PFIN(2,1)
4427 P1(3) = PINI(3,1)-PFIN(3,1)
4428 P1(4) = PINI(4,1)-PFIN(4,1)
4429C incoming electron 2
4430 PINI(1,2) = 0.D0
4431 PINI(2,2) = 0.D0
4432 PINI(3,2) = -EE2
4433 PINI(4,2) = EE2
4434 PINI(5,2) = 0.D0
4435C outgoing electron 2
4436 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4437 Q2E = Q2P2/(4.D0*EE2)
4438 E1Y = EE2*(1.D0-Y2)
4439 CALL PHO_SFECFE(SIF,COF)
4440 PFIN(1,2) = YQ2*COF
4441 PFIN(2,2) = YQ2*SIF
4442 PFIN(3,2) = -E1Y+Q2E
4443 PFIN(4,2) = E1Y+Q2E
4444 PFIN(5,2) = 0.D0
4445C photon 2
4446 P2(1) = -PFIN(1,2)
4447 P2(2) = -PFIN(2,2)
4448 P2(3) = PINI(3,2)-PFIN(3,2)
4449 P2(4) = PINI(4,2)-PFIN(4,2)
4450C ECMS cut
4451 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4452 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4453 IF(GGECM.LT.0.1D0) GOTO 175
4454 GGECM = SQRT(GGECM)
4455 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4456
4457 PGAM(1,1) = P1(1)
4458 PGAM(2,1) = P1(2)
4459 PGAM(3,1) = P1(3)
4460 PGAM(4,1) = P1(4)
4461 PGAM(5,1) = 0.D0
4462 PGAM(1,2) = P2(1)
4463 PGAM(2,2) = P2(2)
4464 PGAM(3,2) = P2(3)
4465 PGAM(4,2) = P2(4)
4466 PGAM(5,2) = 0.D0
4467C photon helicities
4468 IGHEL(1) = 1
4469 IGHEL(2) = 1
4470C cut given by user
4471 CALL PHO_PRESEL(5,IREJ)
4472 IF(IREJ.NE.0) GOTO 175
4473C event generation
4474 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4475 IF(IREJ.NE.0) GOTO 150
4476C statistics
4477 AY1 = AY1+Y1
4478 AYS1 = AYS1+Y1*Y1
4479 AY2 = AY2+Y2
4480 AYS2 = AYS2+Y2*Y2
4481C histograms
4482 CALL PHO_PHIST(1,HSWGHT(0))
4483 CALL PHO_LHIST(1,HSWGHT(0))
4484 200 CONTINUE
4485
4486 WGY = DBLE(ITRY)/DBLE(ITRW)
4487 AY1 = AY1/DBLE(NITER)
4488 AYS1 = AYS1/DBLE(NITER)
4489 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4490 AY2 = AY2/DBLE(NITER)
4491 AYS2 = AYS2/DBLE(NITER)
4492 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4493 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4494C output of statistics, histograms
4495 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4496 &'=========================================================',
4497 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4498 &'========================================================='
4499 WRITE(LO,'(//1X,A,3I10)')
4500 & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4501 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4502 & WGY,WEIGHT
4503 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4504 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4505
4506 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4507 IF(NITER.GT.1) THEN
4508 CALL PHO_PHIST(-2,WEIGHT)
4509 CALL PHO_LHIST(-2,WEIGHT)
4510 ELSE
4511 WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4512 ENDIF
4513
4514 END
4515
4516*$ CREATE pho_samp1d.FOR
4517*COPY pho_samp1d
4518CDECK ID>, pho_samp1d
4519 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4520C***********************************************************************
4521C
4522C Monte Carlo sampling from arbitrary 1d distribution
4523C (linear interpolation to improve reproduction of initial function)
4524C
4525C input: Imode -1 initialization
4526C 1 sampling (after initialization)
4527C X_inp(N_dim) array with x values
4528C F_inp(N_dim) array with function values
4529C F_int(N_dim) array with integral
4530C
4531C output: X_out sampled value (Imode=1)
4532C
4533C (R.E. 10/99)
4534C
4535C***********************************************************************
4536 implicit none
4537 save
4538
4539C input/output channels
4540 INTEGER LI,LO
4541 COMMON /POINOU/ LI,LO
4542
4543 integer Imode,N_dim
4544 double precision X_inp,F_inp,F_int,X_out
4545 dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4546
4547C local variables
4548 integer i
4549 double precision dum,xi,a,b
4550
4551C external functions
4552 double precision DT_RNDM
4553 external DT_RNDM
4554
4555 if(Imode.eq.-1) then
4556
4557C initialization
4558
4559 F_int(1) = 0.D0
4560 do i=2,N_dim
4561 F_int(i) = F_int(i-1)
4562 & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4563 enddo
4564
4565 else if(Imode.eq.1) then
4566
4567C sample from previously calculated integral
4568
4569 xi = DT_RNDM(dum)*F_int(N_dim)
4570
4571 do i=2,N_dim
4572 if(xi.lt.F_int(i)) then
4573 a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4574 b = F_inp(i)-a*X_inp(i)
4575 xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4576 X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4577 return
4578 endif
4579 enddo
4580 X_out = X_inp(N_dim)
4581
4582 else
4583
4584C invalid option Imode
4585
4586 WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4587 X_out = 0.D0
4588
4589 endif
4590
4591 END
4592
4593*$ CREATE pho_ExpBessI0.FOR
4594*COPY pho_ExpBessI0
4595CDECK ID>, pho_ExpBessI0
4596 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4597C**********************************************************************
4598C
4599C Bessel Function I0 times exponential function from neg. arg.
4600C (defined for pos. arguments only)
4601C
4602C**********************************************************************
4603 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4604 SAVE
4605
4606 AX = ABS(X)
4607 IF (AX .LT. 3.75D0) THEN
4608 Y = (X/3.75D0)**2
4609 pho_ExpBessI0 =
4610 & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4611 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4612 ELSE
4613 Y = 3.75D0/AX
4614 pho_ExpBessI0 =
4615 & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4616 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4617 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4618 & +Y*0.392377D-2))))))))
4619 ENDIF
4620
4621 END
4622
4623*$ CREATE PHO_GGBEAM.FOR
4624*COPY PHO_GGBEAM
4625CDECK ID>, PHO_GGBEAM
4626 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4627C**********************************************************************
4628C
4629C interface to call PHOJET (variable energy run) for
4630C gamma-gamma collisions via beamstrahlung
4631C
4632C input: EE LAB system energy of electron/positron
4633C YPSI beamstrahlung parameter
4634C SIGX,Y transverse bunch dimensions
4635C SIGZ longitudinal bunch dimension
4636C AEB number of electrons/positrons in a bunch
4637C NEVENT number of events to generate
4638C from /LEPCUT/:
4639C YMIN1 lower limit of Y
4640C (energy fraction taken by photon from electron)
4641C YMAX1 upper cutoff for Y, necessary to avoid
4642C underflows
4643C
4644C**********************************************************************
4645 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4646 SAVE
4647
4648 PARAMETER ( DEPS = 1.D-20,
4649 & PI = 3.14159265359D0 )
4650
4651C input/output channels
4652 INTEGER LI,LO
4653 COMMON /POINOU/ LI,LO
4654C event debugging information
4655 INTEGER NMAXD
4656 PARAMETER (NMAXD=100)
4657 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4658 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4659 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4660 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4661C photon flux kinematics and cuts
4662 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4663 & YMIN1,YMAX1,YMIN2,YMAX2,
4664 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4665 & THMIN1,THMAX1,THMIN2,THMAX2
4666 INTEGER ITAG1,ITAG2
4667 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4668 & YMIN1,YMAX1,YMIN2,YMAX2,
4669 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4670 & THMIN1,THMAX1,THMIN2,THMAX2,
4671 & ITAG1,ITAG2
4672C gamma-lepton or gamma-hadron vertex information
4673 INTEGER IGHEL,IDPSRC,IDBSRC
4674 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4675 & RADSRC,AMSRC,GAMSRC
4676 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4677 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4678 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4679C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4680 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4681 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4682 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4683 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4684C event weights and generated cross section
4685 INTEGER IPOWGC,ISWCUT,IVWGHT
4686 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4687 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4688 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4689
4690 PARAMETER (Max_tab=100)
4691 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4692C
4693 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4694C electron data
4695 RE = 2.818D-12
4696 ELEM = 0.512D-03
4697 IDPSRC(1) = 0
4698 IDBSRC(1) = 0
4699 IDPSRC(2) = 0
4700 IDBSRC(2) = 0
4701C table of flux function, log interpolation
4702 IF(YPSI.LE.0.D0) THEN
4703 YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4704 ENDIF
4705 WRITE(LO,'(/1X,A,E12.4)')
4706 & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4707 WRITE(LO,'(/1X,A,2E12.4)')
4708 & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4709 TT = 2.D0/3.D0
4710 OT = 1.D0/3.D0
4711C GAOT = DGAMMA(OT)
4712 GAOT = 2.6789385347D0
4713 AKAP = TT/YPSI
4714 WW = 1.D0/(6.D0*SQRT(AKAP))
4715 ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4716 & *YPSI/SQRT(1.D0+YPSI**TT)
4717
4718 YMIN = YMIN1
4719 YMAX = MIN(YMAX1,0.9D0)
4720 TABCU(0) = 0.D0
4721 TABYL(0) = LOG(YMIN)
4722 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4723 FLUX = 0.D0
4724 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4725 & 'PHO_GGBEAM: table of photon flux',Max_tab
4726 DO 100 I=1,Max_tab
4727 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4728 GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4729 FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4730 & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4731 & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4732 TABCU(I) = TABCU(I-1)+FF*Y
4733 TABYL(I) = LOG(Y)
4734 FLUX = FLUX+Y*FF
4735 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4736 100 CONTINUE
4737 FLUX = FLUX*DELLY
4738 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4739 & 'PHO_GGBEAM: integrated flux (one side):',FLUX
4740
4741 EE1 = EE
4742 EE2 = EE
4743C photon 1
4744 EGAM = YMAX*EE
4745 P1(1) = 0.D0
4746 P1(2) = 0.D0
4747 P1(3) = EGAM
4748 P1(4) = EGAM
4749C photon 2
4750 EGAM = YMAX*EE
4751 P2(1) = 0.D0
4752 P2(2) = 0.D0
4753 P2(3) = -EGAM
4754 P2(4) = EGAM
4755 CALL PHO_SETPAR(1,22,0,0.D0)
4756 CALL PHO_SETPAR(2,22,0,0.D0)
4757 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4758 CALL PHO_PHIST(-1,SIGMAX)
4759 CALL PHO_LHIST(-1,SIGMAX)
4760
4761C generation of events
4762 AY1 = 0.D0
4763 AY2 = 0.D0
4764 AYS1 = 0.D0
4765 AYS2 = 0.D0
4766 NITER = NEVENT
4767 ITRY = 0
4768 ITRW = 0
4769 DO 200 I=1,NITER
4770 150 CONTINUE
4771 ITRY = ITRY+1
4772 175 CONTINUE
4773 ITRW = ITRW+1
4774 XI = DT_RNDM(AY1)*TABCU(Max_tab)
4775 DO 110 K=1,Max_tab
4776 IF(TABCU(K).GE.XI) THEN
4777 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4778 Y1 = EXP(Y1)
4779 GOTO 120
4780 ENDIF
4781 110 CONTINUE
4782 Y1 = YMAX
4783 120 CONTINUE
4784 XI = DT_RNDM(AY2)*TABCU(Max_tab)
4785 DO 130 K=1,Max_tab
4786 IF(TABCU(K).GE.XI) THEN
4787 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4788 Y2 = EXP(Y2)
4789 GOTO 140
4790 ENDIF
4791 130 CONTINUE
4792 Y2 = YMAX
4793 140 CONTINUE
4794 Q2P1 = 0.D0
4795 Q2P2 = 0.D0
4796 GYY(1) = Y1
4797 GQ2(1) = Q2P1
4798 GYY(2) = Y2
4799 GQ2(2) = Q2P2
4800C incoming electron 1
4801 PINI(1,1) = 0.D0
4802 PINI(2,1) = 0.D0
4803 PINI(3,1) = EE1
4804 PINI(4,1) = EE1
4805 PINI(5,1) = 0.D0
4806C outgoing electron 1
4807 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4808 Q2E = Q2P1/(4.D0*EE1)
4809 E1Y = EE1*(1.D0-Y1)
4810 CALL PHO_SFECFE(SIF,COF)
4811 PFIN(1,1) = YQ2*COF
4812 PFIN(2,1) = YQ2*SIF
4813 PFIN(3,1) = E1Y-Q2E
4814 PFIN(4,1) = E1Y+Q2E
4815 PFIN(5,1) = 0.D0
4816C photon 1
4817 P1(1) = -PFIN(1,1)
4818 P1(2) = -PFIN(2,1)
4819 P1(3) = PINI(3,1)-PFIN(3,1)
4820 P1(4) = PINI(4,1)-PFIN(4,1)
4821C incoming electron 2
4822 PINI(1,2) = 0.D0
4823 PINI(2,2) = 0.D0
4824 PINI(3,2) = -EE2
4825 PINI(4,2) = EE2
4826 PINI(5,2) = 0.D0
4827C outgoing electron 2
4828 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4829 Q2E = Q2P2/(4.D0*EE2)
4830 E1Y = EE2*(1.D0-Y2)
4831 CALL PHO_SFECFE(SIF,COF)
4832 PFIN(1,2) = YQ2*COF
4833 PFIN(2,2) = YQ2*SIF
4834 PFIN(3,2) = -E1Y+Q2E
4835 PFIN(4,2) = E1Y+Q2E
4836 PFIN(5,2) = 0.D0
4837C photon 2
4838 P2(1) = -PFIN(1,2)
4839 P2(2) = -PFIN(2,2)
4840 P2(3) = PINI(3,2)-PFIN(3,2)
4841 P2(4) = PINI(4,2)-PFIN(4,2)
4842C ECMS cut
4843 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4844 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4845 IF(GGECM.LT.0.1D0) GOTO 175
4846 GGECM = SQRT(GGECM)
4847 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4848C
4849 PGAM(1,1) = P1(1)
4850 PGAM(2,1) = P1(2)
4851 PGAM(3,1) = P1(3)
4852 PGAM(4,1) = P1(4)
4853 PGAM(5,1) = 0.D0
4854 PGAM(1,2) = P2(1)
4855 PGAM(2,2) = P2(2)
4856 PGAM(3,2) = P2(3)
4857 PGAM(4,2) = P2(4)
4858 PGAM(5,2) = 0.D0
4859C photon helicities
4860 IGHEL(1) = 1
4861 IGHEL(2) = 1
4862C cut given by user
4863 CALL PHO_PRESEL(5,IREJ)
4864 IF(IREJ.NE.0) GOTO 175
4865C event generation
4866 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4867 IF(IREJ.NE.0) GOTO 150
4868 GGECML = LOG(GGECM)
4869C statistics
4870 AY1 = AY1+Y1
4871 AYS1 = AYS1+Y1*Y1
4872 AY2 = AY2+Y2
4873 AYS2 = AYS2+Y2*Y2
4874C histograms
4875 CALL PHO_PHIST(1,HSWGHT(0))
4876 CALL PHO_LHIST(1,HSWGHT(0))
4877 200 CONTINUE
4878C
4879 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4880 AY1 = AY1/DBLE(NITER)
4881 AYS1 = AYS1/DBLE(NITER)
4882 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4883 AY2 = AY2/DBLE(NITER)
4884 AYS2 = AYS2/DBLE(NITER)
4885 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4886 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4887C output of statistics, histograms
4888 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4889 &'=========================================================',
4890 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4891 &'========================================================='
4892 WRITE(LO,'(//1X,A,2I10)')
4893 & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4894 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4895 & WGY,WEIGHT
4896 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4897 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4898C
4899 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4900 IF(NITER.GT.1) THEN
4901 CALL PHO_PHIST(-2,WEIGHT)
4902 CALL PHO_LHIST(-2,WEIGHT)
4903 ELSE
4904 WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4905 ENDIF
4906
4907 END
4908
4909*$ CREATE PHO_GGHIOF.FOR
4910*COPY PHO_GGHIOF
4911CDECK ID>, PHO_GGHIOF
4912 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4913C**********************************************************************
4914C
4915C interface to call PHOJET (variable energy run) for
4916C gamma-gamma collisions via heavy ions (form factor approach)
4917C
4918C input: EEN LAB system energy per nucleon
4919C NA atomic number of ion/hadron
4920C NZ charge number of ion/hadron
4921C NEVENT number of events to generate
4922C from /LEPCUT/:
4923C YMIN1,2 lower limit of Y
4924C (energy fraction taken by photon from hadron)
4925C YMAX1,2 upper cutoff for Y, necessary to avoid
4926C underflows
4927C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4928C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4929C corrected according size of hadron)
4930C
4931C currently implemented approximation similar to:
4932C E.Papageorgiu PhysLettB250(1990)155
4933C
4934C**********************************************************************
4935 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4936 SAVE
4937
4938 PARAMETER ( PI = 3.14159265359D0 )
4939
4940C input/output channels
4941 INTEGER LI,LO
4942 COMMON /POINOU/ LI,LO
4943C model switches and parameters
4944 CHARACTER*8 MDLNA
4945 INTEGER ISWMDL,IPAMDL
4946 DOUBLE PRECISION PARMDL
4947 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4948C event debugging information
4949 INTEGER NMAXD
4950 PARAMETER (NMAXD=100)
4951 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4952 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4953 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4954 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4955C photon flux kinematics and cuts
4956 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4957 & YMIN1,YMAX1,YMIN2,YMAX2,
4958 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4959 & THMIN1,THMAX1,THMIN2,THMAX2
4960 INTEGER ITAG1,ITAG2
4961 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4962 & YMIN1,YMAX1,YMIN2,YMAX2,
4963 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4964 & THMIN1,THMAX1,THMIN2,THMAX2,
4965 & ITAG1,ITAG2
4966C gamma-lepton or gamma-hadron vertex information
4967 INTEGER IGHEL,IDPSRC,IDBSRC
4968 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4969 & RADSRC,AMSRC,GAMSRC
4970 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4971 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4972 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4973C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4974 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4975 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4976 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4977 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4978C event weights and generated cross section
4979 INTEGER IPOWGC,ISWCUT,IVWGHT
4980 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4981 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4982 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4983
4984 DIMENSION P1(4),P2(4),BIMP(2,2)
4985C
4986 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
4987 & '--------------------------------------'
4988C hadron size and mass
4989 FM2GEV = 5.07D0
4990 HIMASS = DBLE(NA)*0.938D0
4991 HIMA2 = HIMASS**2
4992 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
4993 ALPHA = DBLE(NZ**2)/137.D0
4994C correct Q2MAX1,2 according to hadron size
4995 Q2MAXH = 2.D0/HIRADI**2
4996 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
4997 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
4998 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
4999 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5000C total hadron / heavy ion energy
5001 EE = EEN*DBLE(NA)
5002 GAMMA = EE/HIMASS
5003C setup /POFSRC/
5004 GAMSRC(1) = GAMMA
5005 GAMSRC(2) = GAMMA
5006 RADSRC(1) = HIRADI
5007 RADSRC(2) = HIRADI
5008 AMSRC(1) = HIMASS
5009 AMSRC(1) = HIMASS
5010C kinematic limitations
5011 YMI = (ECMIN/(2.D0*EE))**2
5012 IF(YMIN1.LT.YMI) THEN
5013 WRITE(LO,'(/1X,A,2E12.5)')
5014 & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5015 YMIN1 = YMI
5016 ELSE IF(YMIN1.GT.YMI) THEN
5017 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5018 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5019 & ' INSTEAD OF',YMIN1
5020 ENDIF
5021 IF(YMIN2.LT.YMI) THEN
5022 WRITE(LO,'(/1X,A,2E12.5)')
5023 & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5024 YMIN2 = YMI
5025 ELSE IF(YMIN2.GT.YMI) THEN
5026 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5027 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5028 & ' INSTEAD OF',YMIN2
5029 ENDIF
5030C kinematic limitation
5031 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5032 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5033C debug output
5034 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5035 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5036 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5037 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5038 & Q2MAX1
5039 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5040 & Q2MAX2
5041 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5042 & YMAX1
5043 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5044 & YMAX2
5045 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5046 & 2.D0*EEN,2.D0*EE
5047 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5048 IF(Q2LOW1.GE.Q2MAX1) THEN
5049 WRITE(LO,'(/1X,A,2E12.4)')
5050 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5051 CALL PHO_ABORT
5052 ENDIF
5053 IF(Q2LOW2.GE.Q2MAX2) THEN
5054 WRITE(LO,'(/1X,A,2E12.4)')
5055 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5056 CALL PHO_ABORT
5057 ENDIF
5058C hadron numbers set to 0
5059 IDPSRC(1) = 0
5060 IDPSRC(2) = 0
5061 IDBSRC(1) = 0
5062 IDBSRC(2) = 0
5063C
5064 Max_tab = 100
5065 YMAX = YMAX1
5066 YMIN = YMIN1
5067 XMAX = LOG(YMAX)
5068 XMIN = LOG(YMIN)
5069 XDEL = XMAX-XMIN
5070 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5071 DO 100 I=1,Max_tab
5072 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5073 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5074 IF(Q2LOW1.GE.Q2MAX1) THEN
5075 WRITE(LO,'(/1X,A,2E12.4)')
5076 & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5077 YMAX1 = MIN(Y1,YMAX1)
5078 GOTO 101
5079 ENDIF
5080 100 CONTINUE
5081 101 CONTINUE
5082 YMAX = YMAX2
5083 YMIN = YMIN2
5084 XMAX = LOG(YMAX)
5085 XMIN = LOG(YMIN)
5086 XDEL = XMAX-XMIN
5087 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5088 DO 102 I=1,Max_tab
5089 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5090 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5091 IF(Q2LOW2.GE.Q2MAX2) THEN
5092 WRITE(LO,'(/1X,A,2E12.4)')
5093 & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5094 YMAX2 = MIN(Y1,YMAX2)
5095 GOTO 103
5096 ENDIF
5097 102 CONTINUE
5098 103 CONTINUE
5099 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5100 IF(YMI.GT.YMIN1) THEN
5101 WRITE(LO,'(/1X,A,2E12.4)')
5102 & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5103 YMIN1 = YMI
5104 ENDIF
5105 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5106 IF(YMI.GT.YMIN2) THEN
5107 WRITE(LO,'(/1X,A,2E12.4)')
5108 & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5109 YMIN2 = YMI
5110 ENDIF
5111C
5112 X1MAX = LOG(YMAX1)
5113 X1MIN = LOG(YMIN1)
5114 X1DEL = X1MAX-X1MIN
5115 X2MAX = LOG(YMAX2)
5116 X2MIN = LOG(YMIN2)
5117 X2DEL = X2MAX-X2MIN
5118 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5119 FLUX = 0.D0
5120 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5121 & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5122 DO 105 I=1,Max_tab
5123 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5124 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5125 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5126 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5127 FLUX = FLUX+Y1*FF
5128 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5129 105 CONTINUE
5130 FLUX = FLUX*DELLY
5131 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5132 & 'PHO_GGHIOF: integrated flux (one side):',FLUX
5133C
5134 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5135 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5136 Y1 = YMIN1
5137 Y2 = YMIN2
5138 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5139 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5140 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5141 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5142C
5143C photon 1
5144 EGAM = YMAX1*EE
5145 P1(1) = 0.D0
5146 P1(2) = 0.D0
5147 P1(3) = EGAM
5148 P1(4) = EGAM
5149C photon 2
5150 EGAM = YMAX2*EE
5151 P2(1) = 0.D0
5152 P2(2) = 0.D0
5153 P2(3) = -EGAM
5154 P2(4) = EGAM
5155 CALL PHO_SETPAR(1,22,0,0.D0)
5156 CALL PHO_SETPAR(2,22,0,0.D0)
5157 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5158 CALL PHO_PHIST(-1,SIGMAX)
5159 CALL PHO_LHIST(-1,SIGMAX)
5160C
5161C generation of events, flux calculation
5162 ECFRAC = ECMIN**2/(4.D0*EE*EE)
5163 AY1 = 0.D0
5164 AY2 = 0.D0
5165 AYS1 = 0.D0
5166 AYS2 = 0.D0
5167 Q21MIN = 1.D30
5168 Q22MIN = 1.D30
5169 Q21MAX = 0.D0
5170 Q22MAX = 0.D0
5171 Q21AVE = 0.D0
5172 Q22AVE = 0.D0
5173 Q21AV2 = 0.D0
5174 Q22AV2 = 0.D0
5175 YY1MIN = 1.D30
5176 YY2MIN = 1.D30
5177 YY1MAX = 0.D0
5178 YY2MAX = 0.D0
5179 NITER = NEVENT
5180 ITRY = 0
5181 ITRW = 0
5182 DO 200 I=1,NITER
5183C sample y1, y2
5184 150 CONTINUE
5185 ITRY = ITRY+1
5186 175 CONTINUE
5187 ITRW = ITRW+1
5188 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5189 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5190 IF(Y1*Y2.LT.ECFRAC) GOTO 175
5191C
5192 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5193 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5194 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5195 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5196 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5197 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5198 WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5199 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5200 & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5201 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5202 IF(WGMAX.LT.WGH) THEN
5203 WRITE(LO,'(1X,A,4E12.5)')
5204 & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5205 ENDIF
5206 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5207C sample Q2
5208 IF(IPAMDL(174).EQ.1) THEN
5209 YEFF = 1.D0+(1.D0-Y1)**2
5210 185 CONTINUE
5211 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5212 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5213 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5214 ELSE
5215 Q2P1 = Q2LOW1
5216 ENDIF
5217 IF(IPAMDL(174).EQ.1) THEN
5218 YEFF = 1.D0+(1.D0-Y2)**2
5219 186 CONTINUE
5220 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5221 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5222 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5223 ELSE
5224 Q2P2 = Q2LOW2
5225 ENDIF
5226C impact parameter
5227 GAIMP(1) = 1.D0/SQRT(Q2P1)
5228 GAIMP(2) = 1.D0/SQRT(Q2P2)
5229C form factor (squared)
5230 FF21 = 1.D0
5231 IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5232 FF22 = 1.D0
5233 IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5234 IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5235C do the hadrons overlap?
5236 IF(ISWMDL(26).GT.0) THEN
5237 DO 190 K=1,2
5238 CALL PHO_SFECFE(SIF,COF)
5239 BIMP(1,K) = SIF*GAIMP(K)
5240 BIMP(2,K) = COF*GAIMP(K)
5241 190 CONTINUE
5242 BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5243 & +(BIMP(2,1)-BIMP(2,2))**2)
5244 IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5245 ENDIF
5246C photon data
5247 GYY(1) = Y1
5248 GQ2(1) = Q2P1
5249 GYY(2) = Y2
5250 GQ2(2) = Q2P2
5251C
5252C incoming hadron 1
5253 PINI(1,1) = 0.D0
5254 PINI(2,1) = 0.D0
5255 PINI(3,1) = EE
5256 PINI(4,1) = EE
5257 PINI(5,1) = 0.D0
5258C outgoing hadron 1
5259 YQ2 = SQRT((1.D0-Y1)*Q2P1)
5260 Q2E = Q2P1/(4.D0*EE)
5261 E1Y = EE*(1.D0-Y1)
5262 CALL PHO_SFECFE(SIF,COF)
5263 PFIN(1,1) = YQ2*COF
5264 PFIN(2,1) = YQ2*SIF
5265 PFIN(3,1) = E1Y-Q2E
5266 PFIN(4,1) = E1Y+Q2E
5267 PFIN(5,1) = 0.D0
5268 PFPHI(1) = ATAN2(COF,SIF)
5269 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5270C photon 1
5271 P1(1) = -PFIN(1,1)
5272 P1(2) = -PFIN(2,1)
5273 P1(3) = PINI(3,1)-PFIN(3,1)
5274 P1(4) = PINI(4,1)-PFIN(4,1)
5275C incoming hadron 2
5276 PINI(1,2) = 0.D0
5277 PINI(2,2) = 0.D0
5278 PINI(3,2) = -EE
5279 PINI(4,2) = EE
5280 PINI(5,2) = 0.D0
5281C outgoing hadron 2
5282 YQ2 = SQRT((1.D0-Y2)*Q2P2)
5283 Q2E = Q2P2/(4.D0*EE)
5284 E1Y = EE*(1.D0-Y2)
5285 CALL PHO_SFECFE(SIF,COF)
5286 PFIN(1,2) = YQ2*COF
5287 PFIN(2,2) = YQ2*SIF
5288 PFIN(3,2) = -E1Y+Q2E
5289 PFIN(4,2) = E1Y+Q2E
5290 PFIN(5,2) = 0.D0
5291 PFPHI(2) = ATAN2(COF,SIF)
5292 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5293C photon 2
5294 P2(1) = -PFIN(1,2)
5295 P2(2) = -PFIN(2,2)
5296 P2(3) = PINI(3,2)-PFIN(3,2)
5297 P2(4) = PINI(4,2)-PFIN(4,2)
5298C ECMS cut
5299 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5300 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5301 IF(GGECM.LT.0.1D0) GOTO 175
5302 GGECM = SQRT(GGECM)
5303 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5304C
5305 PGAM(1,1) = P1(1)
5306 PGAM(2,1) = P1(2)
5307 PGAM(3,1) = P1(3)
5308 PGAM(4,1) = P1(4)
5309 PGAM(5,1) = -SQRT(Q2P1)
5310 PGAM(1,2) = P2(1)
5311 PGAM(2,2) = P2(2)
5312 PGAM(3,2) = P2(3)
5313 PGAM(4,2) = P2(4)
5314 PGAM(5,2) = -SQRT(Q2P2)
5315C photon helicities
5316 IGHEL(1) = 1
5317 IGHEL(2) = 1
5318C cut given by user
5319 CALL PHO_PRESEL(5,IREJ)
5320 IF(IREJ.NE.0) GOTO 175
5321C event generation
5322 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5323 IF(IREJ.NE.0) GOTO 150
5324C statistics
5325 AY1 = AY1+Y1
5326 AYS1 = AYS1+Y1*Y1
5327 AY2 = AY2+Y2
5328 AYS2 = AYS2+Y2*Y2
5329 Q21MIN = MIN(Q21MIN,Q2P1)
5330 Q22MIN = MIN(Q22MIN,Q2P2)
5331 Q21MAX = MAX(Q21MAX,Q2P1)
5332 Q22MAX = MAX(Q22MAX,Q2P2)
5333 YY1MIN = MIN(YY1MIN,Y1)
5334 YY2MIN = MIN(YY2MIN,Y2)
5335 YY1MAX = MAX(YY1MAX,Y1)
5336 YY2MAX = MAX(YY2MAX,Y2)
5337 Q21AVE = Q21AVE+Q2P1
5338 Q22AVE = Q22AVE+Q2P2
5339 Q21AV2 = Q21AV2+Q2P1*Q2P1
5340 Q22AV2 = Q22AV2+Q2P2*Q2P2
5341C histograms
5342 CALL PHO_PHIST(1,HSWGHT(0))
5343 CALL PHO_LHIST(1,HSWGHT(0))
5344 200 CONTINUE
5345C
5346 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5347 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5348 AY1 = AY1/DBLE(NITER)
5349 AYS1 = AYS1/DBLE(NITER)
5350 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5351 AY2 = AY2/DBLE(NITER)
5352 AYS2 = AYS2/DBLE(NITER)
5353 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5354 Q21AVE = Q21AVE/DBLE(NITER)
5355 Q21AV2 = Q21AV2/DBLE(NITER)
5356 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5357 Q22AVE = Q22AVE/DBLE(NITER)
5358 Q22AV2 = Q22AV2/DBLE(NITER)
5359 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5360 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5361C output of statistics, histograms
5362 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5363 &'=========================================================',
5364 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5365 &'========================================================='
5366 WRITE(LO,'(//1X,A,3I10)')
5367 & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5368 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5369 & WGY,WEIGHT
5370 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5371 & AY1,DAY1
5372 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5373 & AY2,DAY2
5374 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5375 & YY1MIN,YY1MAX
5376 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5377 & YY2MIN,YY2MAX
5378 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
5379 & Q21AVE,Q21AV2
5380 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
5381 & Q21MIN,Q21MAX
5382 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
5383 & Q22AVE,Q22AV2
5384 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
5385 & Q22MIN,Q22MAX
5386C
5387 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5388 IF(NITER.GT.1) THEN
5389 CALL PHO_PHIST(-2,WEIGHT)
5390 CALL PHO_LHIST(-2,WEIGHT)
5391 ELSE
5392 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5393 ENDIF
5394
5395 END
5396
5397*$ CREATE PHO_GGHIOG.FOR
5398*COPY PHO_GGHIOG
5399CDECK ID>, PHO_GGHIOG
5400 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5401C**********************************************************************
5402C
5403C interface to call PHOJET (variable energy run) for
5404C gamma-gamma collisions via heavy ions (geometrical approach)
5405C
5406C
5407C input: EEN LAB system energy per nucleon
5408C NA atomic number of ion/hadron
5409C NZ charge number of ion/hadron
5410C NEVENT number of events to generate
5411C from /LEPCUT/:
5412C YMIN1,2 lower limit of Y
5413C (energy fraction taken by photon from hadron)
5414C YMAX1,2 upper cutoff for Y, necessary to avoid
5415C underflows
5416C
5417C currently implemented approximation similar to:
5418C
5419C
5420C**********************************************************************
5421 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5422 SAVE
5423
5424 PARAMETER ( DEPS = 1.D-20,
5425 & PI = 3.14159265359D0 )
5426
5427C input/output channels
5428 INTEGER LI,LO
5429 COMMON /POINOU/ LI,LO
5430C event debugging information
5431 INTEGER NMAXD
5432 PARAMETER (NMAXD=100)
5433 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5434 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5435 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5436 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5437C photon flux kinematics and cuts
5438 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5439 & YMIN1,YMAX1,YMIN2,YMAX2,
5440 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5441 & THMIN1,THMAX1,THMIN2,THMAX2
5442 INTEGER ITAG1,ITAG2
5443 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5444 & YMIN1,YMAX1,YMIN2,YMAX2,
5445 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5446 & THMIN1,THMAX1,THMIN2,THMAX2,
5447 & ITAG1,ITAG2
5448C gamma-lepton or gamma-hadron vertex information
5449 INTEGER IGHEL,IDPSRC,IDBSRC
5450 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5451 & RADSRC,AMSRC,GAMSRC
5452 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5453 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5454 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5455C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5456 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5457 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5458 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5459 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5460C event weights and generated cross section
5461 INTEGER IPOWGC,ISWCUT,IVWGHT
5462 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5463 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5464 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5465
5466 PARAMETER (Max_tab=100)
5467 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5468C
5469 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5470 & '---------------------------------------'
5471C hadron size and mass
5472 FM2GEV = 5.07D0
5473 HIMASS = DBLE(NA)*0.938D0
5474 HIMA2 = HIMASS**2
5475 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5476 ALPHA = DBLE(NZ**2)/137.D0
5477C total hadron / heavy ion energy
5478 EE = EEN*DBLE(NA)
5479 GAMMA = EE/HIMASS
5480C setup /POFSRC/
5481 GAMSRC(1) = GAMMA
5482 GAMSRC(2) = GAMMA
5483 RADSRC(1) = HIRADI
5484 RADSRC(2) = HIRADI
5485 AMSRC(1) = HIMASS
5486 AMSRC(1) = HIMASS
5487C kinematic limitations
5488 YMI = (ECMIN/(2.D0*EE))**2
5489 IF(YMIN1.LT.YMI) THEN
5490 WRITE(LO,'(/1X,A,2E12.5)')
5491 & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5492 YMIN1 = YMI
5493 ELSE IF(YMIN1.GT.YMI) THEN
5494 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5495 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5496 & ' INSTEAD OF',YMIN1
5497 ENDIF
5498 IF(YMIN2.LT.YMI) THEN
5499 WRITE(LO,'(/1X,A,2E12.5)')
5500 & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5501 YMIN2 = YMI
5502 ELSE IF(YMIN2.GT.YMI) THEN
5503 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5504 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5505 & ' INSTEAD OF',YMIN2
5506 ENDIF
5507C debug output
5508 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5509 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5510 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5511 WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
5512 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5513 & YMAX1
5514 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5515 & YMAX2
5516 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5517 & 2.D0*EEN,2.D0*EE
5518 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5519C hadron numbers set to 0
5520 IDPSRC(1) = 0
5521 IDBSRC(1) = 0
5522 IDPSRC(2) = 0
5523 IDBSRC(2) = 0
5524C table of flux function, log interpolation
5525 YMIN = YMIN1
5526 YMAX = YMAX1
5527 YMAX = MIN(YMAX,0.9999999D0)
5528 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5529 TABYL(0) = LOG(YMIN)
5530 FFMAX = 0.D0
5531 DO 100 I=1,Max_tab
5532 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5533 WG = EE*Y
5534 XI = WG*HIRADI/GAMMA
5535 FF = ALPHA*PHO_GGFLCL(XI)/Y
5536 FFMAX = MAX(FF,FFMAX)
5537 IF(FF.LT.1.D-10*FFMAX) THEN
5538 WRITE(LO,'(/1X,A,2E12.4)')
5539 & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5540 YMAX1 = MIN(Y,YMAX1)
5541 GOTO 101
5542 ENDIF
5543 100 CONTINUE
5544 101 CONTINUE
5545 YMIN = YMIN2
5546 YMAX = YMAX2
5547 YMAX = MIN(YMAX,0.9999999D0)
5548 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5549 TABYL(0) = LOG(YMIN)
5550 FFMAX = 0.D0
5551 DO 102 I=1,Max_tab
5552 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5553 WG = EE*Y
5554 XI = WG*HIRADI/GAMMA
5555 FF = ALPHA*PHO_GGFLCL(XI)/Y
5556 FFMAX = MAX(FF,FFMAX)
5557 IF(FF.LT.1.D-10*FFMAX) THEN
5558 WRITE(LO,'(/1X,A,2E12.4)')
5559 & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5560 YMAX2 = MIN(Y,YMAX2)
5561 GOTO 103
5562 ENDIF
5563 102 CONTINUE
5564 103 CONTINUE
5565 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5566 IF(YMI.GT.YMIN1) THEN
5567 WRITE(LO,'(/1X,A,2E12.4)')
5568 & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5569 YMIN1 = YMI
5570 ENDIF
5571 YMAX1 = MIN(YMAX,YMAX1)
5572 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5573 IF(YMI.GT.YMIN2) THEN
5574 WRITE(LO,'(/1X,A,2E12.4)')
5575 & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5576 YMIN2 = YMI
5577 ENDIF
5578C
5579 YMIN = YMIN1
5580 YMAX = YMAX1
5581 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5582 TABCU(0) = 0.D0
5583 TABYL(0) = LOG(YMIN)
5584 FLUX = 0.D0
5585 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5586 & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5587 DO 105 I=1,Max_tab
5588 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5589 WG = EE*Y
5590 XI = WG*HIRADI/GAMMA
5591 FF = ALPHA*PHO_GGFLCL(XI)/Y
5592 FFMAX = MAX(FF,FFMAX)
5593 TABCU(I) = TABCU(I-1)+FF*Y
5594 TABYL(I) = LOG(Y)
5595 FLUX = FLUX+Y*FF
5596 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5597 105 CONTINUE
5598 FLUX = FLUX*DELLY
5599 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5600 & 'PHO_GGHIOG: integrated flux (one side):',FLUX
5601C
5602C initialization
5603C photon 1
5604 EGAM = YMAX*EE
5605 P1(1) = 0.D0
5606 P1(2) = 0.D0
5607 P1(3) = EGAM
5608 P1(4) = EGAM
5609C photon 2
5610 EGAM = YMAX*EE
5611 P2(1) = 0.D0
5612 P2(2) = 0.D0
5613 P2(3) = -EGAM
5614 P2(4) = EGAM
5615 CALL PHO_SETPAR(1,22,0,0.D0)
5616 CALL PHO_SETPAR(2,22,0,0.D0)
5617 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5618 CALL PHO_PHIST(-1,SIGMAX)
5619 CALL PHO_LHIST(-1,SIGMAX)
5620C
5621C generation of events
5622 AY1 = 0.D0
5623 AY2 = 0.D0
5624 AYS1 = 0.D0
5625 AYS2 = 0.D0
5626 YY1MIN = 1.D30
5627 YY2MIN = 1.D30
5628 YY1MAX = 0.D0
5629 YY2MAX = 0.D0
5630 NITER = NEVENT
5631 ITRY = 0
5632 ITRW = 0
5633 DO 200 I=1,NITER
5634 150 CONTINUE
5635 ITRY = ITRY+1
5636 175 CONTINUE
5637 ITRW = ITRW+1
5638 XI = DT_RNDM(AY1)*TABCU(Max_tab)
5639 DO 110 K=1,Max_tab
5640 IF(TABCU(K).GE.XI) THEN
5641 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5642 Y1 = EXP(Y1)
5643 GOTO 120
5644 ENDIF
5645 110 CONTINUE
5646 Y1 = YMAX1
5647 120 CONTINUE
5648 XI = DT_RNDM(AY2)*TABCU(Max_tab)
5649 DO 130 K=1,Max_tab
5650 IF(TABCU(K).GE.XI) THEN
5651 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5652 Y2 = EXP(Y2)
5653 GOTO 140
5654 ENDIF
5655 130 CONTINUE
5656 Y2 = YMAX2
5657 140 CONTINUE
5658C setup kinematics
5659 GYY(1) = Y1
5660 GQ2(1) = 0.D0
5661 GYY(2) = Y2
5662 GQ2(2) = 0.D0
5663C incoming electron 1
5664 PINI(1,1) = 0.D0
5665 PINI(2,1) = 0.D0
5666 PINI(3,1) = EE
5667 PINI(4,1) = EE
5668 PINI(5,1) = 0.D0
5669C outgoing electron 1
5670 E1Y = EE*(1.D0-Y1)
5671 PFIN(1,1) = 0.D0
5672 PFIN(2,1) = 0.D0
5673 PFIN(3,1) = E1Y
5674 PFIN(4,1) = E1Y
5675 PFIN(5,1) = 0.D0
5676C photon 1
5677 P1(1) = -PFIN(1,1)
5678 P1(2) = -PFIN(2,1)
5679 P1(3) = PINI(3,1)-PFIN(3,1)
5680 P1(4) = PINI(4,1)-PFIN(4,1)
5681C incoming electron 2
5682 PINI(1,2) = 0.D0
5683 PINI(2,2) = 0.D0
5684 PINI(3,2) = -EE
5685 PINI(4,2) = EE
5686 PINI(5,2) = 0.D0
5687C outgoing electron 2
5688 E1Y = EE*(1.D0-Y2)
5689 PFIN(1,2) = 0.D0
5690 PFIN(2,2) = 0.D0
5691 PFIN(3,2) = -E1Y
5692 PFIN(4,2) = E1Y
5693 PFIN(5,2) = 0.D0
5694C photon 2
5695 P2(1) = -PFIN(1,2)
5696 P2(2) = -PFIN(2,2)
5697 P2(3) = PINI(3,2)-PFIN(3,2)
5698 P2(4) = PINI(4,2)-PFIN(4,2)
5699C ECMS cut
5700 GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5701 IF(GGECM.LT.0.1D0) GOTO 175
5702 GGECM = SQRT(GGECM)
5703 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5704 PGAM(1,1) = P1(1)
5705 PGAM(2,1) = P1(2)
5706 PGAM(3,1) = P1(3)
5707 PGAM(4,1) = P1(4)
5708 PGAM(5,1) = 0.D0
5709 PGAM(1,2) = P2(1)
5710 PGAM(2,2) = P2(2)
5711 PGAM(3,2) = P2(3)
5712 PGAM(4,2) = P2(4)
5713 PGAM(5,2) = 0.D0
5714C impact parameter constraints
5715 XI1 = P1(4)*HIRADI/GAMMA
5716 XI2 = P2(4)*HIRADI/GAMMA
5717 FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5718 FCORR = PHO_GGFLCR(HIRADI)
5719 WGX = (FLX-FCORR)/FLX
5720 IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5721C photon helicities
5722 IGHEL(1) = 1
5723 IGHEL(2) = 1
5724C cut given by user
5725 CALL PHO_PRESEL(5,IREJ)
5726 IF(IREJ.NE.0) GOTO 175
5727C event generation
5728 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5729 IF(IREJ.NE.0) GOTO 150
5730C statistics
5731 AY1 = AY1+Y1
5732 AYS1 = AYS1+Y1*Y1
5733 AY2 = AY2+Y2
5734 AYS2 = AYS2+Y2*Y2
5735 YY1MIN = MIN(YY1MIN,Y1)
5736 YY2MIN = MIN(YY2MIN,Y2)
5737 YY1MAX = MAX(YY1MAX,Y1)
5738 YY2MAX = MAX(YY2MAX,Y2)
5739C histograms
5740 CALL PHO_PHIST(1,HSWGHT(0))
5741 CALL PHO_LHIST(1,HSWGHT(0))
5742 200 CONTINUE
5743C
5744 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5745 AY1 = AY1/DBLE(NITER)
5746 AYS1 = AYS1/DBLE(NITER)
5747 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5748 AY2 = AY2/DBLE(NITER)
5749 AYS2 = AYS2/DBLE(NITER)
5750 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5751 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5752C output of statistics, histograms
5753 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5754 &'=========================================================',
5755 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5756 &'========================================================='
5757 WRITE(LO,'(//1X,A,3I12)')
5758 & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5759 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5760 & WGY,WEIGHT
5761 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5762 & AY1,DAY1
5763 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5764 & AY2,DAY2
5765 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5766 & YY1MIN,YY1MAX
5767 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5768 & YY2MIN,YY2MAX
5769
5770C
5771 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5772 IF(NITER.GT.1) THEN
5773 CALL PHO_PHIST(-2,WEIGHT)
5774 CALL PHO_LHIST(-2,WEIGHT)
5775 ELSE
5776 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5777 ENDIF
5778
5779 END
5780
5781*$ CREATE PHO_GGFLCL.FOR
5782*COPY PHO_GGFLCL
5783CDECK ID>, PHO_GGFLCL
5784 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5785C*********************************************************************
5786C
5787C semi-classical photon flux (geometrical model)
5788C
5789C*********************************************************************
5790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5791 SAVE
5792
5793 PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5794 & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5795
5796 END
5797
5798*$ CREATE PHO_GGFLCR.FOR
5799*COPY PHO_GGFLCR
5800CDECK ID>, PHO_GGFLCR
5801 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5802C*********************************************************************
5803C
5804C semi-classical photon flux correction due to
5805C overlap in impact parameter space (geometrical model)
5806C
5807C*********************************************************************
5808 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5809 SAVE
5810
5811 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5812
5813C input/output channels
5814 INTEGER LI,LO
5815 COMMON /POINOU/ LI,LO
5816C gamma-lepton or gamma-hadron vertex information
5817 INTEGER IGHEL,IDPSRC,IDBSRC
5818 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5819 & RADSRC,AMSRC,GAMSRC
5820 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5821 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5822 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5823
5824 DIMENSION XGAUSS(126),WGAUSS(126)
5825
5826 DATA XGAUSS(1)/ .57735026918962576D0/
5827 DATA XGAUSS(2)/-.57735026918962576D0/
5828 DATA WGAUSS(1)/ 1.00000000000000000D0/
5829 DATA WGAUSS(2)/ 1.00000000000000000D0/
5830
5831 DATA XGAUSS(3)/ .33998104358485627D0/
5832 DATA XGAUSS(4)/ .86113631159405258D0/
5833 DATA XGAUSS(5)/-.33998104358485627D0/
5834 DATA XGAUSS(6)/-.86113631159405258D0/
5835 DATA WGAUSS(3)/ .65214515486254613D0/
5836 DATA WGAUSS(4)/ .34785484513745385D0/
5837 DATA WGAUSS(5)/ .65214515486254613D0/
5838 DATA WGAUSS(6)/ .34785484513745385D0/
5839
5840 DATA XGAUSS(7)/ .18343464249564981D0/
5841 DATA XGAUSS(8)/ .52553240991632899D0/
5842 DATA XGAUSS(9)/ .79666647741362674D0/
5843 DATA XGAUSS(10)/ .96028985649753623D0/
5844 DATA XGAUSS(11)/-.18343464249564981D0/
5845 DATA XGAUSS(12)/-.52553240991632899D0/
5846 DATA XGAUSS(13)/-.79666647741362674D0/
5847 DATA XGAUSS(14)/-.96028985649753623D0/
5848 DATA WGAUSS(7)/ .36268378337836198D0/
5849 DATA WGAUSS(8)/ .31370664587788727D0/
5850 DATA WGAUSS(9)/ .22238103445337448D0/
5851 DATA WGAUSS(10)/ .10122853629037627D0/
5852 DATA WGAUSS(11)/ .36268378337836198D0/
5853 DATA WGAUSS(12)/ .31370664587788727D0/
5854 DATA WGAUSS(13)/ .22238103445337448D0/
5855 DATA WGAUSS(14)/ .10122853629037627D0/
5856
5857 DATA XGAUSS(15)/ .0950125098376374402D0/
5858 DATA XGAUSS(16)/ .281603550779258913D0/
5859 DATA XGAUSS(17)/ .458016777657227386D0/
5860 DATA XGAUSS(18)/ .617876244402643748D0/
5861 DATA XGAUSS(19)/ .755404408355003034D0/
5862 DATA XGAUSS(20)/ .865631202387831744D0/
5863 DATA XGAUSS(21)/ .944575023073232576D0/
5864 DATA XGAUSS(22)/ .989400934991649933D0/
5865 DATA XGAUSS(23)/-.0950125098376374402D0/
5866 DATA XGAUSS(24)/-.281603550779258913D0/
5867 DATA XGAUSS(25)/-.458016777657227386D0/
5868 DATA XGAUSS(26)/-.617876244402643748D0/
5869 DATA XGAUSS(27)/-.755404408355003034D0/
5870 DATA XGAUSS(28)/-.865631202387831744D0/
5871 DATA XGAUSS(29)/-.944575023073232576D0/
5872 DATA XGAUSS(30)/-.989400934991649933D0/
5873 DATA WGAUSS(15)/ .189450610455068496D0/
5874 DATA WGAUSS(16)/ .182603415044923589D0/
5875 DATA WGAUSS(17)/ .169156519395002538D0/
5876 DATA WGAUSS(18)/ .149595988816576732D0/
5877 DATA WGAUSS(19)/ .124628971255533872D0/
5878 DATA WGAUSS(20)/ .0951585116824927848D0/
5879 DATA WGAUSS(21)/ .0622535239386478929D0/
5880 DATA WGAUSS(22)/ .0271524594117540949D0/
5881 DATA WGAUSS(23)/ .189450610455068496D0/
5882 DATA WGAUSS(24)/ .182603415044923589D0/
5883 DATA WGAUSS(25)/ .169156519395002538D0/
5884 DATA WGAUSS(26)/ .149595988816576732D0/
5885 DATA WGAUSS(27)/ .124628971255533872D0/
5886 DATA WGAUSS(28)/ .0951585116824927848D0/
5887 DATA WGAUSS(29)/ .0622535239386478929D0/
5888 DATA WGAUSS(30)/ .0271524594117540949D0/
5889
5890 DATA XGAUSS(31)/ .0483076656877383162D0/
5891 DATA XGAUSS(32)/ .144471961582796493D0/
5892 DATA XGAUSS(33)/ .239287362252137075D0/
5893 DATA XGAUSS(34)/ .331868602282127650D0/
5894 DATA XGAUSS(35)/ .421351276130635345D0/
5895 DATA XGAUSS(36)/ .506899908932229390D0/
5896 DATA XGAUSS(37)/ .587715757240762329D0/
5897 DATA XGAUSS(38)/ .663044266930215201D0/
5898 DATA XGAUSS(39)/ .732182118740289680D0/
5899 DATA XGAUSS(40)/ .794483795967942407D0/
5900 DATA XGAUSS(41)/ .849367613732569970D0/
5901 DATA XGAUSS(42)/ .896321155766052124D0/
5902 DATA XGAUSS(43)/ .934906075937739689D0/
5903 DATA XGAUSS(44)/ .964762255587506430D0/
5904 DATA XGAUSS(45)/ .985611511545268335D0/
5905 DATA XGAUSS(46)/ .997263861849481564D0/
5906 DATA XGAUSS(47)/-.0483076656877383162D0/
5907 DATA XGAUSS(48)/-.144471961582796493D0/
5908 DATA XGAUSS(49)/-.239287362252137075D0/
5909 DATA XGAUSS(50)/-.331868602282127650D0/
5910 DATA XGAUSS(51)/-.421351276130635345D0/
5911 DATA XGAUSS(52)/-.506899908932229390D0/
5912 DATA XGAUSS(53)/-.587715757240762329D0/
5913 DATA XGAUSS(54)/-.663044266930215201D0/
5914 DATA XGAUSS(55)/-.732182118740289680D0/
5915 DATA XGAUSS(56)/-.794483795967942407D0/
5916 DATA XGAUSS(57)/-.849367613732569970D0/
5917 DATA XGAUSS(58)/-.896321155766052124D0/
5918 DATA XGAUSS(59)/-.934906075937739689D0/
5919 DATA XGAUSS(60)/-.964762255587506430D0/
5920 DATA XGAUSS(61)/-.985611511545268335D0/
5921 DATA XGAUSS(62)/-.997263861849481564D0/
5922 DATA WGAUSS(31)/ .0965400885147278006D0/
5923 DATA WGAUSS(32)/ .0956387200792748594D0/
5924 DATA WGAUSS(33)/ .0938443990808045654D0/
5925 DATA WGAUSS(34)/ .0911738786957638847D0/
5926 DATA WGAUSS(35)/ .0876520930044038111D0/
5927 DATA WGAUSS(36)/ .0833119242269467552D0/
5928 DATA WGAUSS(37)/ .0781938957870703065D0/
5929 DATA WGAUSS(38)/ .0723457941088485062D0/
5930 DATA WGAUSS(39)/ .0658222227763618468D0/
5931 DATA WGAUSS(40)/ .0586840934785355471D0/
5932 DATA WGAUSS(41)/ .0509980592623761762D0/
5933 DATA WGAUSS(42)/ .0428358980222266807D0/
5934 DATA WGAUSS(43)/ .0342738629130214331D0/
5935 DATA WGAUSS(44)/ .0253920653092620595D0/
5936 DATA WGAUSS(45)/ .0162743947309056706D0/
5937 DATA WGAUSS(46)/ .00701861000947009660D0/
5938 DATA WGAUSS(47)/ .0965400885147278006D0/
5939 DATA WGAUSS(48)/ .0956387200792748594D0/
5940 DATA WGAUSS(49)/ .0938443990808045654D0/
5941 DATA WGAUSS(50)/ .0911738786957638847D0/
5942 DATA WGAUSS(51)/ .0876520930044038111D0/
5943 DATA WGAUSS(52)/ .0833119242269467552D0/
5944 DATA WGAUSS(53)/ .0781938957870703065D0/
5945 DATA WGAUSS(54)/ .0723457941088485062D0/
5946 DATA WGAUSS(55)/ .0658222227763618468D0/
5947 DATA WGAUSS(56)/ .0586840934785355471D0/
5948 DATA WGAUSS(57)/ .0509980592623761762D0/
5949 DATA WGAUSS(58)/ .0428358980222266807D0/
5950 DATA WGAUSS(59)/ .0342738629130214331D0/
5951 DATA WGAUSS(60)/ .0253920653092620595D0/
5952 DATA WGAUSS(61)/ .0162743947309056706D0/
5953 DATA WGAUSS(62)/ .00701861000947009660D0/
5954
5955 DATA XGAUSS(63)/ .02435029266342443250D0/
5956 DATA XGAUSS(64)/ .0729931217877990394D0/
5957 DATA XGAUSS(65)/ .121462819296120554D0/
5958 DATA XGAUSS(66)/ .169644420423992818D0/
5959 DATA XGAUSS(67)/ .217423643740007084D0/
5960 DATA XGAUSS(68)/ .264687162208767416D0/
5961 DATA XGAUSS(69)/ .311322871990210956D0/
5962 DATA XGAUSS(70)/ .357220158337668116D0/
5963 DATA XGAUSS(71)/ .402270157963991604D0/
5964 DATA XGAUSS(72)/ .446366017253464088D0/
5965 DATA XGAUSS(73)/ .489403145707052957D0/
5966 DATA XGAUSS(74)/ .531279464019894546D0/
5967 DATA XGAUSS(75)/ .571895646202634034D0/
5968 DATA XGAUSS(76)/ .611155355172393250D0/
5969 DATA XGAUSS(77)/ .648965471254657340D0/
5970 DATA XGAUSS(78)/ .685236313054233243D0/
5971 DATA XGAUSS(79)/ .719881850171610827D0/
5972 DATA XGAUSS(80)/ .752819907260531897D0/
5973 DATA XGAUSS(81)/ .783972358943341408D0/
5974 DATA XGAUSS(82)/ .813265315122797560D0/
5975 DATA XGAUSS(83)/ .840629296252580363D0/
5976 DATA XGAUSS(84)/ .865999398154092820D0/
5977 DATA XGAUSS(85)/ .889315445995114106D0/
5978 DATA XGAUSS(86)/ .910522137078502806D0/
5979 DATA XGAUSS(87)/ .929569172131939576D0/
5980 DATA XGAUSS(88)/ .946411374858402816D0/
5981 DATA XGAUSS(89)/ .961008799652053719D0/
5982 DATA XGAUSS(90)/ .973326827789910964D0/
5983 DATA XGAUSS(91)/ .983336253884625957D0/
5984 DATA XGAUSS(92)/ .991013371476744321D0/
5985 DATA XGAUSS(93)/ .996340116771955279D0/
5986 DATA XGAUSS(94)/ .999305041735772139D0/
5987 DATA XGAUSS(95)/-.02435029266342443250D0/
5988 DATA XGAUSS(96)/-.0729931217877990394D0/
5989 DATA XGAUSS(97)/-.121462819296120554D0/
5990 DATA XGAUSS(98)/-.169644420423992818D0/
5991 DATA XGAUSS(99)/-.217423643740007084D0/
5992 DATA XGAUSS(100)/-.264687162208767416D0/
5993 DATA XGAUSS(101)/-.311322871990210956D0/
5994 DATA XGAUSS(102)/-.357220158337668116D0/
5995 DATA XGAUSS(103)/-.402270157963991604D0/
5996 DATA XGAUSS(104)/-.446366017253464088D0/
5997 DATA XGAUSS(105)/-.489403145707052957D0/
5998 DATA XGAUSS(106)/-.531279464019894546D0/
5999 DATA XGAUSS(107)/-.571895646202634034D0/
6000 DATA XGAUSS(108)/-.611155355172393250D0/
6001 DATA XGAUSS(109)/-.648965471254657340D0/
6002 DATA XGAUSS(110)/-.685236313054233243D0/
6003 DATA XGAUSS(111)/-.719881850171610827D0/
6004 DATA XGAUSS(112)/-.752819907260531897D0/
6005 DATA XGAUSS(113)/-.783972358943341408D0/
6006 DATA XGAUSS(114)/-.813265315122797560D0/
6007 DATA XGAUSS(115)/-.840629296252580363D0/
6008 DATA XGAUSS(116)/-.865999398154092820D0/
6009 DATA XGAUSS(117)/-.889315445995114106D0/
6010 DATA XGAUSS(118)/-.910522137078502806D0/
6011 DATA XGAUSS(119)/-.929569172131939576D0/
6012 DATA XGAUSS(120)/-.946411374858402816D0/
6013 DATA XGAUSS(121)/-.961008799652053719D0/
6014 DATA XGAUSS(122)/-.973326827789910964D0/
6015 DATA XGAUSS(123)/-.983336253884625957D0/
6016 DATA XGAUSS(124)/-.991013371476744321D0/
6017 DATA XGAUSS(125)/-.996340116771955279D0/
6018 DATA XGAUSS(126)/-.999305041735772139D0/
6019 DATA WGAUSS(63)/ .0486909570091397204D0/
6020 DATA WGAUSS(64)/ .0485754674415034269D0/
6021 DATA WGAUSS(65)/ .0483447622348029572D0/
6022 DATA WGAUSS(66)/ .0479993885964583077D0/
6023 DATA WGAUSS(67)/ .0475401657148303087D0/
6024 DATA WGAUSS(68)/ .0469681828162100173D0/
6025 DATA WGAUSS(69)/ .0462847965813144172D0/
6026 DATA WGAUSS(70)/ .0454916279274181445D0/
6027 DATA WGAUSS(71)/ .0445905581637565631D0/
6028 DATA WGAUSS(72)/ .0435837245293234534D0/
6029 DATA WGAUSS(73)/ .0424735151236535890D0/
6030 DATA WGAUSS(74)/ .0412625632426235286D0/
6031 DATA WGAUSS(75)/ .0399537411327203414D0/
6032 DATA WGAUSS(76)/ .0385501531786156291D0/
6033 DATA WGAUSS(77)/ .0370551285402400460D0/
6034 DATA WGAUSS(78)/ .0354722132568823838D0/
6035 DATA WGAUSS(79)/ .0338051618371416094D0/
6036 DATA WGAUSS(80)/ .0320579283548515535D0/
6037 DATA WGAUSS(81)/ .0302346570724024789D0/
6038 DATA WGAUSS(82)/ .0283396726142594832D0/
6039 DATA WGAUSS(83)/ .0263774697150546587D0/
6040 DATA WGAUSS(84)/ .0243527025687108733D0/
6041 DATA WGAUSS(85)/ .0222701738083832542D0/
6042 DATA WGAUSS(86)/ .0201348231535302094D0/
6043 DATA WGAUSS(87)/ .0179517157756973431D0/
6044 DATA WGAUSS(88)/ .0157260304760247193D0/
6045 DATA WGAUSS(89)/ .0134630478967186426D0/
6046 DATA WGAUSS(90)/ .0111681394601311288D0/
6047 DATA WGAUSS(91)/ .00884675982636394772D0/
6048 DATA WGAUSS(92)/ .00650445796897836286D0/
6049 DATA WGAUSS(93)/ .00414703326056246764D0/
6050 DATA WGAUSS(94)/ .00178328072169643295D0/
6051 DATA WGAUSS(95)/ .0486909570091397204D0/
6052 DATA WGAUSS(96)/ .0485754674415034269D0/
6053 DATA WGAUSS(97)/ .0483447622348029572D0/
6054 DATA WGAUSS(98)/ .0479993885964583077D0/
6055 DATA WGAUSS(99)/ .0475401657148303087D0/
6056 DATA WGAUSS(100)/ .0469681828162100173D0/
6057 DATA WGAUSS(101)/ .0462847965813144172D0/
6058 DATA WGAUSS(102)/ .0454916279274181445D0/
6059 DATA WGAUSS(103)/ .0445905581637565631D0/
6060 DATA WGAUSS(104)/ .0435837245293234534D0/
6061 DATA WGAUSS(105)/ .0424735151236535890D0/
6062 DATA WGAUSS(106)/ .0412625632426235286D0/
6063 DATA WGAUSS(107)/ .0399537411327203414D0/
6064 DATA WGAUSS(108)/ .0385501531786156291D0/
6065 DATA WGAUSS(109)/ .0370551285402400460D0/
6066 DATA WGAUSS(110)/ .0354722132568823838D0/
6067 DATA WGAUSS(111)/ .0338051618371416094D0/
6068 DATA WGAUSS(112)/ .0320579283548515535D0/
6069 DATA WGAUSS(113)/ .0302346570724024789D0/
6070 DATA WGAUSS(114)/ .0283396726142594832D0/
6071 DATA WGAUSS(115)/ .0263774697150546587D0/
6072 DATA WGAUSS(116)/ .0243527025687108733D0/
6073 DATA WGAUSS(117)/ .0222701738083832542D0/
6074 DATA WGAUSS(118)/ .0201348231535302094D0/
6075 DATA WGAUSS(119)/ .0179517157756973431D0/
6076 DATA WGAUSS(120)/ .0157260304760247193D0/
6077 DATA WGAUSS(121)/ .0134630478967186426D0/
6078 DATA WGAUSS(122)/ .0111681394601311288D0/
6079 DATA WGAUSS(123)/ .00884675982636394772D0/
6080 DATA WGAUSS(124)/ .00650445796897836286D0/
6081 DATA WGAUSS(125)/ .00414703326056246764D0/
6082 DATA WGAUSS(126)/ .00178328072169643295D0/
6083
6084C integrate first over b1
6085C
6086C Loop incrementing the boundary
6087C
6088 tmin = 0.D0
6089 tmax = 0.25D0
6090 Sum = 0.D0
6091
6092 50 CONTINUE
6093
6094C
6095C Loop for the Gauss integration
6096C
6097 XINT=0.D0
6098 DO 100 N=1,6
6099 XINT2 = XINT
6100 XINT=0.D0
6101 DO 200 I=2**N-1,2**(N+1)-2
6102 t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6103 b1 = RADSRC(1) * EXP (t)
6104 XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6105 200 CONTINUE
6106 XINT = (tmax-tmin)/2.D0*XINT
6107 IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6108 100 CONTINUE
6109 WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6110 300 CONTINUE
6111
6112 Sum = Sum + XINT
6113 IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6114 tmin = tmax
6115 tmax = tmax + 0.5D0
6116 GOTO 50
6117 ENDIF
6118
6119 PHO_GGFLCR = 4.D0*Pi * Sum
6120
6121 END
6122
6123*$ CREATE PHO_GGFAUX.FOR
6124*COPY PHO_GGFAUX
6125CDECK ID>, PHO_GGFAUX
6126 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6127C*********************************************************************
6128C
6129C auxiliary function for integration over b2,
6130C semi-classical photon flux correction due to
6131C overlap in impact parameter space (geometrical model)
6132C
6133C*********************************************************************
6134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6135 SAVE
6136
6137 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6138
6139C input/output channels
6140 INTEGER LI,LO
6141 COMMON /POINOU/ LI,LO
6142C gamma-lepton or gamma-hadron vertex information
6143 INTEGER IGHEL,IDPSRC,IDBSRC
6144 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6145 & RADSRC,AMSRC,GAMSRC
6146 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6147 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6148 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6149
6150 DIMENSION XGAUSS(126),WGAUSS(126)
6151
6152 DATA XGAUSS(1)/ .57735026918962576D0/
6153 DATA XGAUSS(2)/-.57735026918962576D0/
6154 DATA WGAUSS(1)/ 1.00000000000000000D0/
6155 DATA WGAUSS(2)/ 1.00000000000000000D0/
6156
6157 DATA XGAUSS(3)/ .33998104358485627D0/
6158 DATA XGAUSS(4)/ .86113631159405258D0/
6159 DATA XGAUSS(5)/-.33998104358485627D0/
6160 DATA XGAUSS(6)/-.86113631159405258D0/
6161 DATA WGAUSS(3)/ .65214515486254613D0/
6162 DATA WGAUSS(4)/ .34785484513745385D0/
6163 DATA WGAUSS(5)/ .65214515486254613D0/
6164 DATA WGAUSS(6)/ .34785484513745385D0/
6165
6166 DATA XGAUSS(7)/ .18343464249564981D0/
6167 DATA XGAUSS(8)/ .52553240991632899D0/
6168 DATA XGAUSS(9)/ .79666647741362674D0/
6169 DATA XGAUSS(10)/ .96028985649753623D0/
6170 DATA XGAUSS(11)/-.18343464249564981D0/
6171 DATA XGAUSS(12)/-.52553240991632899D0/
6172 DATA XGAUSS(13)/-.79666647741362674D0/
6173 DATA XGAUSS(14)/-.96028985649753623D0/
6174 DATA WGAUSS(7)/ .36268378337836198D0/
6175 DATA WGAUSS(8)/ .31370664587788727D0/
6176 DATA WGAUSS(9)/ .22238103445337448D0/
6177 DATA WGAUSS(10)/ .10122853629037627D0/
6178 DATA WGAUSS(11)/ .36268378337836198D0/
6179 DATA WGAUSS(12)/ .31370664587788727D0/
6180 DATA WGAUSS(13)/ .22238103445337448D0/
6181 DATA WGAUSS(14)/ .10122853629037627D0/
6182
6183 DATA XGAUSS(15)/ .0950125098376374402D0/
6184 DATA XGAUSS(16)/ .281603550779258913D0/
6185 DATA XGAUSS(17)/ .458016777657227386D0/
6186 DATA XGAUSS(18)/ .617876244402643748D0/
6187 DATA XGAUSS(19)/ .755404408355003034D0/
6188 DATA XGAUSS(20)/ .865631202387831744D0/
6189 DATA XGAUSS(21)/ .944575023073232576D0/
6190 DATA XGAUSS(22)/ .989400934991649933D0/
6191 DATA XGAUSS(23)/-.0950125098376374402D0/
6192 DATA XGAUSS(24)/-.281603550779258913D0/
6193 DATA XGAUSS(25)/-.458016777657227386D0/
6194 DATA XGAUSS(26)/-.617876244402643748D0/
6195 DATA XGAUSS(27)/-.755404408355003034D0/
6196 DATA XGAUSS(28)/-.865631202387831744D0/
6197 DATA XGAUSS(29)/-.944575023073232576D0/
6198 DATA XGAUSS(30)/-.989400934991649933D0/
6199 DATA WGAUSS(15)/ .189450610455068496D0/
6200 DATA WGAUSS(16)/ .182603415044923589D0/
6201 DATA WGAUSS(17)/ .169156519395002538D0/
6202 DATA WGAUSS(18)/ .149595988816576732D0/
6203 DATA WGAUSS(19)/ .124628971255533872D0/
6204 DATA WGAUSS(20)/ .0951585116824927848D0/
6205 DATA WGAUSS(21)/ .0622535239386478929D0/
6206 DATA WGAUSS(22)/ .0271524594117540949D0/
6207 DATA WGAUSS(23)/ .189450610455068496D0/
6208 DATA WGAUSS(24)/ .182603415044923589D0/
6209 DATA WGAUSS(25)/ .169156519395002538D0/
6210 DATA WGAUSS(26)/ .149595988816576732D0/
6211 DATA WGAUSS(27)/ .124628971255533872D0/
6212 DATA WGAUSS(28)/ .0951585116824927848D0/
6213 DATA WGAUSS(29)/ .0622535239386478929D0/
6214 DATA WGAUSS(30)/ .0271524594117540949D0/
6215
6216 DATA XGAUSS(31)/ .0483076656877383162D0/
6217 DATA XGAUSS(32)/ .144471961582796493D0/
6218 DATA XGAUSS(33)/ .239287362252137075D0/
6219 DATA XGAUSS(34)/ .331868602282127650D0/
6220 DATA XGAUSS(35)/ .421351276130635345D0/
6221 DATA XGAUSS(36)/ .506899908932229390D0/
6222 DATA XGAUSS(37)/ .587715757240762329D0/
6223 DATA XGAUSS(38)/ .663044266930215201D0/
6224 DATA XGAUSS(39)/ .732182118740289680D0/
6225 DATA XGAUSS(40)/ .794483795967942407D0/
6226 DATA XGAUSS(41)/ .849367613732569970D0/
6227 DATA XGAUSS(42)/ .896321155766052124D0/
6228 DATA XGAUSS(43)/ .934906075937739689D0/
6229 DATA XGAUSS(44)/ .964762255587506430D0/
6230 DATA XGAUSS(45)/ .985611511545268335D0/
6231 DATA XGAUSS(46)/ .997263861849481564D0/
6232 DATA XGAUSS(47)/-.0483076656877383162D0/
6233 DATA XGAUSS(48)/-.144471961582796493D0/
6234 DATA XGAUSS(49)/-.239287362252137075D0/
6235 DATA XGAUSS(50)/-.331868602282127650D0/
6236 DATA XGAUSS(51)/-.421351276130635345D0/
6237 DATA XGAUSS(52)/-.506899908932229390D0/
6238 DATA XGAUSS(53)/-.587715757240762329D0/
6239 DATA XGAUSS(54)/-.663044266930215201D0/
6240 DATA XGAUSS(55)/-.732182118740289680D0/
6241 DATA XGAUSS(56)/-.794483795967942407D0/
6242 DATA XGAUSS(57)/-.849367613732569970D0/
6243 DATA XGAUSS(58)/-.896321155766052124D0/
6244 DATA XGAUSS(59)/-.934906075937739689D0/
6245 DATA XGAUSS(60)/-.964762255587506430D0/
6246 DATA XGAUSS(61)/-.985611511545268335D0/
6247 DATA XGAUSS(62)/-.997263861849481564D0/
6248 DATA WGAUSS(31)/ .0965400885147278006D0/
6249 DATA WGAUSS(32)/ .0956387200792748594D0/
6250 DATA WGAUSS(33)/ .0938443990808045654D0/
6251 DATA WGAUSS(34)/ .0911738786957638847D0/
6252 DATA WGAUSS(35)/ .0876520930044038111D0/
6253 DATA WGAUSS(36)/ .0833119242269467552D0/
6254 DATA WGAUSS(37)/ .0781938957870703065D0/
6255 DATA WGAUSS(38)/ .0723457941088485062D0/
6256 DATA WGAUSS(39)/ .0658222227763618468D0/
6257 DATA WGAUSS(40)/ .0586840934785355471D0/
6258 DATA WGAUSS(41)/ .0509980592623761762D0/
6259 DATA WGAUSS(42)/ .0428358980222266807D0/
6260 DATA WGAUSS(43)/ .0342738629130214331D0/
6261 DATA WGAUSS(44)/ .0253920653092620595D0/
6262 DATA WGAUSS(45)/ .0162743947309056706D0/
6263 DATA WGAUSS(46)/ .00701861000947009660D0/
6264 DATA WGAUSS(47)/ .0965400885147278006D0/
6265 DATA WGAUSS(48)/ .0956387200792748594D0/
6266 DATA WGAUSS(49)/ .0938443990808045654D0/
6267 DATA WGAUSS(50)/ .0911738786957638847D0/
6268 DATA WGAUSS(51)/ .0876520930044038111D0/
6269 DATA WGAUSS(52)/ .0833119242269467552D0/
6270 DATA WGAUSS(53)/ .0781938957870703065D0/
6271 DATA WGAUSS(54)/ .0723457941088485062D0/
6272 DATA WGAUSS(55)/ .0658222227763618468D0/
6273 DATA WGAUSS(56)/ .0586840934785355471D0/
6274 DATA WGAUSS(57)/ .0509980592623761762D0/
6275 DATA WGAUSS(58)/ .0428358980222266807D0/
6276 DATA WGAUSS(59)/ .0342738629130214331D0/
6277 DATA WGAUSS(60)/ .0253920653092620595D0/
6278 DATA WGAUSS(61)/ .0162743947309056706D0/
6279 DATA WGAUSS(62)/ .00701861000947009660D0/
6280
6281 DATA XGAUSS(63)/ .02435029266342443250D0/
6282 DATA XGAUSS(64)/ .0729931217877990394D0/
6283 DATA XGAUSS(65)/ .121462819296120554D0/
6284 DATA XGAUSS(66)/ .169644420423992818D0/
6285 DATA XGAUSS(67)/ .217423643740007084D0/
6286 DATA XGAUSS(68)/ .264687162208767416D0/
6287 DATA XGAUSS(69)/ .311322871990210956D0/
6288 DATA XGAUSS(70)/ .357220158337668116D0/
6289 DATA XGAUSS(71)/ .402270157963991604D0/
6290 DATA XGAUSS(72)/ .446366017253464088D0/
6291 DATA XGAUSS(73)/ .489403145707052957D0/
6292 DATA XGAUSS(74)/ .531279464019894546D0/
6293 DATA XGAUSS(75)/ .571895646202634034D0/
6294 DATA XGAUSS(76)/ .611155355172393250D0/
6295 DATA XGAUSS(77)/ .648965471254657340D0/
6296 DATA XGAUSS(78)/ .685236313054233243D0/
6297 DATA XGAUSS(79)/ .719881850171610827D0/
6298 DATA XGAUSS(80)/ .752819907260531897D0/
6299 DATA XGAUSS(81)/ .783972358943341408D0/
6300 DATA XGAUSS(82)/ .813265315122797560D0/
6301 DATA XGAUSS(83)/ .840629296252580363D0/
6302 DATA XGAUSS(84)/ .865999398154092820D0/
6303 DATA XGAUSS(85)/ .889315445995114106D0/
6304 DATA XGAUSS(86)/ .910522137078502806D0/
6305 DATA XGAUSS(87)/ .929569172131939576D0/
6306 DATA XGAUSS(88)/ .946411374858402816D0/
6307 DATA XGAUSS(89)/ .961008799652053719D0/
6308 DATA XGAUSS(90)/ .973326827789910964D0/
6309 DATA XGAUSS(91)/ .983336253884625957D0/
6310 DATA XGAUSS(92)/ .991013371476744321D0/
6311 DATA XGAUSS(93)/ .996340116771955279D0/
6312 DATA XGAUSS(94)/ .999305041735772139D0/
6313 DATA XGAUSS(95)/-.02435029266342443250D0/
6314 DATA XGAUSS(96)/-.0729931217877990394D0/
6315 DATA XGAUSS(97)/-.121462819296120554D0/
6316 DATA XGAUSS(98)/-.169644420423992818D0/
6317 DATA XGAUSS(99)/-.217423643740007084D0/
6318 DATA XGAUSS(100)/-.264687162208767416D0/
6319 DATA XGAUSS(101)/-.311322871990210956D0/
6320 DATA XGAUSS(102)/-.357220158337668116D0/
6321 DATA XGAUSS(103)/-.402270157963991604D0/
6322 DATA XGAUSS(104)/-.446366017253464088D0/
6323 DATA XGAUSS(105)/-.489403145707052957D0/
6324 DATA XGAUSS(106)/-.531279464019894546D0/
6325 DATA XGAUSS(107)/-.571895646202634034D0/
6326 DATA XGAUSS(108)/-.611155355172393250D0/
6327 DATA XGAUSS(109)/-.648965471254657340D0/
6328 DATA XGAUSS(110)/-.685236313054233243D0/
6329 DATA XGAUSS(111)/-.719881850171610827D0/
6330 DATA XGAUSS(112)/-.752819907260531897D0/
6331 DATA XGAUSS(113)/-.783972358943341408D0/
6332 DATA XGAUSS(114)/-.813265315122797560D0/
6333 DATA XGAUSS(115)/-.840629296252580363D0/
6334 DATA XGAUSS(116)/-.865999398154092820D0/
6335 DATA XGAUSS(117)/-.889315445995114106D0/
6336 DATA XGAUSS(118)/-.910522137078502806D0/
6337 DATA XGAUSS(119)/-.929569172131939576D0/
6338 DATA XGAUSS(120)/-.946411374858402816D0/
6339 DATA XGAUSS(121)/-.961008799652053719D0/
6340 DATA XGAUSS(122)/-.973326827789910964D0/
6341 DATA XGAUSS(123)/-.983336253884625957D0/
6342 DATA XGAUSS(124)/-.991013371476744321D0/
6343 DATA XGAUSS(125)/-.996340116771955279D0/
6344 DATA XGAUSS(126)/-.999305041735772139D0/
6345 DATA WGAUSS(63)/ .0486909570091397204D0/
6346 DATA WGAUSS(64)/ .0485754674415034269D0/
6347 DATA WGAUSS(65)/ .0483447622348029572D0/
6348 DATA WGAUSS(66)/ .0479993885964583077D0/
6349 DATA WGAUSS(67)/ .0475401657148303087D0/
6350 DATA WGAUSS(68)/ .0469681828162100173D0/
6351 DATA WGAUSS(69)/ .0462847965813144172D0/
6352 DATA WGAUSS(70)/ .0454916279274181445D0/
6353 DATA WGAUSS(71)/ .0445905581637565631D0/
6354 DATA WGAUSS(72)/ .0435837245293234534D0/
6355 DATA WGAUSS(73)/ .0424735151236535890D0/
6356 DATA WGAUSS(74)/ .0412625632426235286D0/
6357 DATA WGAUSS(75)/ .0399537411327203414D0/
6358 DATA WGAUSS(76)/ .0385501531786156291D0/
6359 DATA WGAUSS(77)/ .0370551285402400460D0/
6360 DATA WGAUSS(78)/ .0354722132568823838D0/
6361 DATA WGAUSS(79)/ .0338051618371416094D0/
6362 DATA WGAUSS(80)/ .0320579283548515535D0/
6363 DATA WGAUSS(81)/ .0302346570724024789D0/
6364 DATA WGAUSS(82)/ .0283396726142594832D0/
6365 DATA WGAUSS(83)/ .0263774697150546587D0/
6366 DATA WGAUSS(84)/ .0243527025687108733D0/
6367 DATA WGAUSS(85)/ .0222701738083832542D0/
6368 DATA WGAUSS(86)/ .0201348231535302094D0/
6369 DATA WGAUSS(87)/ .0179517157756973431D0/
6370 DATA WGAUSS(88)/ .0157260304760247193D0/
6371 DATA WGAUSS(89)/ .0134630478967186426D0/
6372 DATA WGAUSS(90)/ .0111681394601311288D0/
6373 DATA WGAUSS(91)/ .00884675982636394772D0/
6374 DATA WGAUSS(92)/ .00650445796897836286D0/
6375 DATA WGAUSS(93)/ .00414703326056246764D0/
6376 DATA WGAUSS(94)/ .00178328072169643295D0/
6377 DATA WGAUSS(95)/ .0486909570091397204D0/
6378 DATA WGAUSS(96)/ .0485754674415034269D0/
6379 DATA WGAUSS(97)/ .0483447622348029572D0/
6380 DATA WGAUSS(98)/ .0479993885964583077D0/
6381 DATA WGAUSS(99)/ .0475401657148303087D0/
6382 DATA WGAUSS(100)/ .0469681828162100173D0/
6383 DATA WGAUSS(101)/ .0462847965813144172D0/
6384 DATA WGAUSS(102)/ .0454916279274181445D0/
6385 DATA WGAUSS(103)/ .0445905581637565631D0/
6386 DATA WGAUSS(104)/ .0435837245293234534D0/
6387 DATA WGAUSS(105)/ .0424735151236535890D0/
6388 DATA WGAUSS(106)/ .0412625632426235286D0/
6389 DATA WGAUSS(107)/ .0399537411327203414D0/
6390 DATA WGAUSS(108)/ .0385501531786156291D0/
6391 DATA WGAUSS(109)/ .0370551285402400460D0/
6392 DATA WGAUSS(110)/ .0354722132568823838D0/
6393 DATA WGAUSS(111)/ .0338051618371416094D0/
6394 DATA WGAUSS(112)/ .0320579283548515535D0/
6395 DATA WGAUSS(113)/ .0302346570724024789D0/
6396 DATA WGAUSS(114)/ .0283396726142594832D0/
6397 DATA WGAUSS(115)/ .0263774697150546587D0/
6398 DATA WGAUSS(116)/ .0243527025687108733D0/
6399 DATA WGAUSS(117)/ .0222701738083832542D0/
6400 DATA WGAUSS(118)/ .0201348231535302094D0/
6401 DATA WGAUSS(119)/ .0179517157756973431D0/
6402 DATA WGAUSS(120)/ .0157260304760247193D0/
6403 DATA WGAUSS(121)/ .0134630478967186426D0/
6404 DATA WGAUSS(122)/ .0111681394601311288D0/
6405 DATA WGAUSS(123)/ .00884675982636394772D0/
6406 DATA WGAUSS(124)/ .00650445796897836286D0/
6407 DATA WGAUSS(125)/ .00414703326056246764D0/
6408 DATA WGAUSS(126)/ .00178328072169643295D0/
6409C
6410 W1 = PGAM(4,1)
6411 W2 = PGAM(4,2)
6412 bmin = b1 - 2.D0*RADSRC(1)
6413 IF (RADSRC(1) .GT. bmin) THEN
6414 bmin = RADSRC(1)
6415 ENDIF
6416 bmax = b1 + 2.D0 * RADSRC(1)
6417
6418 XINT = 0.D0
6419 DO 100 N=1,6
6420 XINT2 = XINT
6421 XINT = 0.D0
6422 DO 200 I=2**N-1,2**(N+1)-2
6423 b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6424 XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6425 & * PHO_GGFNUC(W2,b2,GAMSRC(2))
6426 & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6427 XINT = XINT +WGAUSS(I) * b2 * XINT3
6428 200 CONTINUE
6429 XINT = (bmax-bmin)/2.D0*XINT
6430 IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6431 100 CONTINUE
6432 WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6433 300 CONTINUE
6434
6435 PHO_GGFAUX = XINT
6436
6437 END
6438
6439*$ CREATE PHO_GGFNUC.FOR
6440*COPY PHO_GGFNUC
6441CDECK ID>, PHO_GGFNUC
6442 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6443C**********************************************************************
6444C
6445C differential photonnumber for a nucleus (geometrical model)
6446C (without form factor)
6447C
6448C*********************************************************************
6449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6450 SAVE
6451
6452 PARAMETER (PI = 3.14159265359D0)
6453
6454 WGamma = W/Gamma
6455 Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6456
6457 PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6458
6459 END
6460
6461*$ CREATE PHO_GHHIOF.FOR
6462*COPY PHO_GHHIOF
6463CDECK ID>, PHO_GHHIOF
6464 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6465C**********************************************************************
6466C
6467C interface to call PHOJET (variable energy run) for
6468C gamma-hadron collisions in heavy ion collisions
6469C (form factor approach)
6470C
6471C input: EEN LAB system energy per nucleon
6472C NA atomic number of ion/hadron
6473C NZ charge number of ion/hadron
6474C NEVENT number of events to generate
6475C from /LEPCUT/:
6476C YMIN1,2 lower limit of Y
6477C (energy fraction taken by photon from hadron)
6478C YMAX1,2 upper cutoff for Y, necessary to avoid
6479C underflows
6480C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6481C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6482C corrected according size of hadron)
6483C
6484C**********************************************************************
6485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6486 SAVE
6487
6488 PARAMETER ( PI = 3.14159265359D0 )
6489
6490C input/output channels
6491 INTEGER LI,LO
6492 COMMON /POINOU/ LI,LO
6493C model switches and parameters
6494 CHARACTER*8 MDLNA
6495 INTEGER ISWMDL,IPAMDL
6496 DOUBLE PRECISION PARMDL
6497 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6498C event debugging information
6499 INTEGER NMAXD
6500 PARAMETER (NMAXD=100)
6501 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6502 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6503 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6504 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6505C photon flux kinematics and cuts
6506 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6507 & YMIN1,YMAX1,YMIN2,YMAX2,
6508 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6509 & THMIN1,THMAX1,THMIN2,THMAX2
6510 INTEGER ITAG1,ITAG2
6511 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6512 & YMIN1,YMAX1,YMIN2,YMAX2,
6513 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6514 & THMIN1,THMAX1,THMIN2,THMAX2,
6515 & ITAG1,ITAG2
6516C gamma-lepton or gamma-hadron vertex information
6517 INTEGER IGHEL,IDPSRC,IDBSRC
6518 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6519 & RADSRC,AMSRC,GAMSRC
6520 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6521 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6522 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6523C nucleon-nucleus / nucleus-nucleus interface to DPMJET
6524 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6525 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6526 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6527 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6528C standard particle data interface
6529 INTEGER NMXHEP
6530 PARAMETER (NMXHEP=4000)
6531 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6532 DOUBLE PRECISION PHEP,VHEP
6533 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6534 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6535 & VHEP(4,NMXHEP)
6536C extension to standard particle data interface (PHOJET specific)
6537 INTEGER IMPART,IPHIST,ICOLOR
6538 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6539C event weights and generated cross section
6540 INTEGER IPOWGC,ISWCUT,IVWGHT
6541 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6542 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6543 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6544
6545 DIMENSION P1(4),P2(4)
6546 DIMENSION NITERS(2),ITRW(2)
6547
6548 WRITE(LO,'(2(/1X,A))')
6549 & 'PHO_GHHIOF: gamma-hadron event generation',
6550 & '-----------------------------------------'
6551C hadron size and mass
6552 FM2GEV = 5.07D0
6553 HIMASS = DBLE(NA)*0.938D0
6554 HIMA2 = HIMASS**2
6555 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6556 ALPHA = DBLE(NZ**2)/137.D0
6557 AMP = 0.938D0
6558 AMP2 = AMP**2
6559C correct Q2MAX1,2 according to hadron size
6560 Q2MAXH = 2.D0/HIRADI**2
6561 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6562 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6563 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6564 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6565C total hadron / heavy ion energy
6566 EE = EEN*DBLE(NA)
6567 GAMMA = EE/HIMASS
6568C setup /POFSRC/
6569 GAMSRC(1) = GAMMA
6570 GAMSRC(2) = GAMMA
6571 RADSRC(1) = HIRADI
6572 RADSRC(2) = HIRADI
6573 AMSRC(1) = HIMASS
6574 AMSRC(2) = HIMASS
6575C check cuts on photon-hadron mass
6576 IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6577 YMI = ECMIN
6578 ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
6579 WRITE(LO,'(/1X,A,2E12.5)')
6580 & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6581 ENDIF
6582C check kinematic limitations
6583 YMI = ECMIN**2/(4.D0*EE*EEN)
6584 IF(YMIN1.LT.YMI) THEN
6585 WRITE(LO,'(/1X,A,2E12.5)')
6586 & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6587 YMIN1 = YMI
6588 ELSE IF(YMIN1.GT.YMI) THEN
6589 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6590 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6591 & ' INSTEAD OF',YMIN1
6592 ENDIF
6593 IF(YMIN2.LT.YMI) THEN
6594 WRITE(LO,'(/1X,A,2E12.5)')
6595 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6596 YMIN2 = YMI
6597 ELSE IF(YMIN2.GT.YMI) THEN
6598 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6599 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6600 & ' INSTEAD OF',YMIN2
6601 ENDIF
6602C kinematic limitation
6603 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6604 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6605C debug output
6606 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
6607 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
6608 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
6609 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6610 & Q2MAX1
6611 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6612 & Q2MAX2
6613 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
6614 & YMAX1
6615 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
6616 & YMAX2
6617 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
6618 & 2.D0*EEN,2.D0*EE
6619 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
6620 & ECMAX
6621 WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6622 & PARMDL(175)
6623 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
6624 IF(Q2LOW1.GE.Q2MAX1) THEN
6625 WRITE(LO,'(/1X,A,2E12.4)')
6626 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6627 CALL PHO_ABORT
6628 ENDIF
6629 IF(Q2LOW2.GE.Q2MAX2) THEN
6630 WRITE(LO,'(/1X,A,2E12.4)')
6631 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6632 CALL PHO_ABORT
6633 ENDIF
6634C hadron numbers set to 0
6635 IDPSRC(1) = 0
6636 IDPSRC(2) = 0
6637 IDBSRC(1) = 0
6638 IDBSRC(2) = 0
6639C
6640 Max_tab = 100
6641 YMAX = YMAX1
6642 YMIN = YMIN1
6643 XMAX = LOG(YMAX)
6644 XMIN = LOG(YMIN)
6645 XDEL = XMAX-XMIN
6646 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6647 DO 100 I=1,Max_tab
6648 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6649 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6650 IF(Q2LOW1.GE.Q2MAX1) THEN
6651 WRITE(LO,'(/1X,A,2E12.4)')
6652 & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6653 YMAX1 = MIN(Y1,YMAX1)
6654 GOTO 101
6655 ENDIF
6656 100 CONTINUE
6657 101 CONTINUE
6658 YMAX = YMAX2
6659 YMIN = YMIN2
6660 XMAX = LOG(YMAX)
6661 XMIN = LOG(YMIN)
6662 XDEL = XMAX-XMIN
6663 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6664 DO 102 I=1,Max_tab
6665 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6666 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6667 IF(Q2LOW2.GE.Q2MAX2) THEN
6668 WRITE(LO,'(/1X,A,2E12.4)')
6669 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6670 YMAX2 = MIN(Y1,YMAX2)
6671 GOTO 103
6672 ENDIF
6673 102 CONTINUE
6674 103 CONTINUE
6675C
6676 X1MAX = LOG(YMAX1)
6677 X1MIN = LOG(YMIN1)
6678 X1DEL = X1MAX-X1MIN
6679 X2MAX = LOG(YMAX2)
6680 X2MIN = LOG(YMIN2)
6681 X2DEL = X2MAX-X2MIN
6682 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6683 FLUX = 0.D0
6684 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6685 & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6686 DO 105 I=1,Max_tab
6687 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6688 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6689 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6690 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6691 FLUX = FLUX+Y1*FF
6692 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6693 105 CONTINUE
6694 FLUX = FLUX*DELLY
6695 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6696 & 'PHO_GHHIOF: integrated flux (one side):',FLUX
6697C
6698C photon
6699 EGAM = MAX(YMAX1,YMAX2)*EE
6700 P1(1) = 0.D0
6701 P1(2) = 0.D0
6702 P1(3) = EGAM
6703 P1(4) = EGAM
6704C hadron
6705 P2(1) = 0.D0
6706 P2(2) = 0.D0
6707 P2(3) = -SQRT(EEN**2-AMP2)
6708 P2(4) = EEN
6709 CALL PHO_SETPAR(1,22,0,0.D0)
6710 CALL PHO_SETPAR(2,2212,0,0.D0)
6711 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6712C
6713 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6714 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6715 Y1 = YMIN1
6716 Y2 = YMIN2
6717 WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6718 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6719 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6720 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6721C
6722 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6723 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6724C
6725 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6726 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6727C
6728 CALL PHO_PHIST(-1,SIGMAX)
6729 CALL PHO_LHIST(-1,SIGMAX)
6730C
6731C generation of events, flux calculation
6732 AY1 = 0.D0
6733 AY2 = 0.D0
6734 AYS1 = 0.D0
6735 AYS2 = 0.D0
6736 Q21MIN = 1.D30
6737 Q22MIN = 1.D30
6738 Q21MAX = 0.D0
6739 Q22MAX = 0.D0
6740 Q21AVE = 0.D0
6741 Q22AVE = 0.D0
6742 Q21AV2 = 0.D0
6743 Q22AV2 = 0.D0
6744 YY1MIN = 1.D30
6745 YY2MIN = 1.D30
6746 YY1MAX = 0.D0
6747 YY2MAX = 0.D0
6748 NITER = NEVENT
6749 NITERS(1) = 0
6750 NITERS(2) = 0
6751 ITRY = 0
6752 ITRW(1) = 0
6753 ITRW(2) = 0
6754 DO 200 I=1,NITER
6755C sample y1, y2
6756 150 CONTINUE
6757 ITRY = ITRY+1
6758 175 CONTINUE
6759C
6760C select side of photon emission
6761 IF(DT_RNDM(AY1).LT.FAC12) THEN
6762 ITRW(1) = ITRW(1)+1
6763C select Y1
6764 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6765 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6766 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6767 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6768 WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6769 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6770 IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6771 & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6772 IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6773C sample Q2
6774 IF(IPAMDL(174).EQ.1) THEN
6775 YEFF = 1.D0+(1.D0-Y1)**2
6776 185 CONTINUE
6777 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6778 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6779 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6780 ELSE
6781 Q2P1 = Q2LOW1
6782 ENDIF
6783C impact parameter
6784 GAIMP(1) = 1.D0/SQRT(Q2P1)
6785C form factor (squared)
6786 FF2 = 1.D0
6787 IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6788 IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6789C photon data
6790 GYY(1) = Y1
6791 GQ2(1) = Q2P1
6792C
6793C incoming hadron 1
6794 PINI(1,1) = 0.D0
6795 PINI(2,1) = 0.D0
6796 PINI(3,1) = SQRT(EE**2-AMP2)
6797 PINI(4,1) = EE
6798 PINI(5,1) = AMP
6799C outgoing hadron 1
6800 YQ2 = SQRT((1.D0-Y1)*Q2P1)
6801 Q2E = Q2P1/(4.D0*EE)
6802 E1Y = EE*(1.D0-Y1)
6803 CALL PHO_SFECFE(SIF,COF)
6804 PFIN(1,1) = YQ2*COF
6805 PFIN(2,1) = YQ2*SIF
6806 PFIN(3,1) = E1Y-Q2E
6807 PFIN(4,1) = E1Y+Q2E
6808 PFIN(5,1) = 0.D0
6809 PFPHI(1) = ATAN2(COF,SIF)
6810 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6811C incoming hadron 2
6812 PINI(1,2) = 0.D0
6813 PINI(2,2) = 0.D0
6814 PINI(3,2) = -SQRT(EE**2-AMP2)
6815 PINI(4,2) = EE
6816 PINI(5,2) = AMP
6817C scattering photon
6818 P1(1) = -PFIN(1,1)
6819 P1(2) = -PFIN(2,1)
6820 P1(3) = PINI(3,1)-PFIN(3,1)
6821 P1(4) = PINI(4,1)-PFIN(4,1)
6822C scattering hadron
6823 P2(1) = 0.D0
6824 P2(2) = 0.D0
6825 P2(3) = -SQRT(EEN**2-AMP2)
6826 P2(4) = EEN
6827 ISIDE = 1
6828C
6829 ELSE
6830C
6831 ITRW(2) = ITRW(2)+1
6832C select Y2
6833 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6834 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6835 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6836 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6837 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6838 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6839 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6840 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6841 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6842C sample Q2
6843 IF(IPAMDL(174).EQ.1) THEN
6844 YEFF = 1.D0+(1.D0-Y2)**2
6845 186 CONTINUE
6846 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6847 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6848 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6849 ELSE
6850 Q2P2 = Q2LOW2
6851 ENDIF
6852C impact parameter
6853 GAIMP(2) = 1.D0/SQRT(Q2P2)
6854C form factor (squared)
6855 FF2 = 1.D0
6856 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6857 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6858C photon data
6859 GYY(2) = Y2
6860 GQ2(2) = Q2P2
6861C
6862C incoming hadron 1
6863 PINI(1,1) = 0.D0
6864 PINI(2,1) = 0.D0
6865 PINI(3,1) = SQRT(EE**2-AMP2)
6866 PINI(4,1) = EE
6867 PINI(5,1) = AMP
6868C incoming hadron 2
6869 PINI(1,2) = 0.D0
6870 PINI(2,2) = 0.D0
6871 PINI(3,2) = -SQRT(EE**2-AMP2)
6872 PINI(4,2) = EE
6873 PINI(5,2) = AMP
6874C outgoing hadron 2
6875 YQ2 = SQRT((1.D0-Y2)*Q2P2)
6876 Q2E = Q2P2/(4.D0*EE)
6877 E1Y = EE*(1.D0-Y2)
6878 CALL PHO_SFECFE(SIF,COF)
6879 PFIN(1,2) = YQ2*COF
6880 PFIN(2,2) = YQ2*SIF
6881 PFIN(3,2) = -E1Y+Q2E
6882 PFIN(4,2) = E1Y+Q2E
6883 PFIN(5,2) = 0.D0
6884 PFPHI(2) = ATAN2(COF,SIF)
6885 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6886C scattering hadron
6887 P2(1) = 0.D0
6888 P2(2) = 0.D0
6889 P2(3) = SQRT(EEN**2-AMP2)
6890 P2(4) = EEN
6891C scattering photon
6892 P1(1) = -PFIN(1,2)
6893 P1(2) = -PFIN(2,2)
6894 P1(3) = PINI(3,2)-PFIN(3,2)
6895 P1(4) = PINI(4,2)-PFIN(4,2)
6896 ISIDE = 2
6897 ENDIF
6898C ECMS cut
6899 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6900 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6901 IF(GGECM.LT.0.1D0) GOTO 175
6902 GGECM = SQRT(GGECM)
6903 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6904C
6905 PGAM(1,1) = P1(1)
6906 PGAM(2,1) = P1(2)
6907 PGAM(3,1) = P1(3)
6908 PGAM(4,1) = P1(4)
6909 PGAM(5,1) = -SQRT(Q2P1)
6910 PGAM(1,2) = P2(1)
6911 PGAM(2,2) = P2(2)
6912 PGAM(3,2) = P2(3)
6913 PGAM(4,2) = P2(4)
6914 PGAM(5,2) = -SQRT(Q2P2)
6915 CALL PHO_PRESEL(5,IREJ)
6916C photon helicities
6917 IGHEL(1) = 1
6918 IGHEL(2) = 1
6919C user cuts
6920 IF(IREJ.NE.0) GOTO 175
6921C event generation
6922 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6923 IF(IREJ.NE.0) GOTO 150
6924C cut on diffractive mass
6925 DO 250 K=1,NHEP
6926 IF(ISTHEP(K).EQ.30) THEN
6927 GHDIFF = PHEP(1,K)
6928 IF(GHDIFF.GE.PARMDL(175)) THEN
6929 GOTO 251
6930 ELSE
6931 GOTO 150
6932 ENDIF
6933 ENDIF
6934 250 CONTINUE
6935 WRITE(LO,'(/,1X,A)')
6936 & 'PHO_GHHIOF: no diffractive entry found'
6937 CALL PHO_PREVNT(-1)
6938 GOTO 150
6939 251 CONTINUE
6940C remove quasi-elastically scattered hadron
6941 DO 260 K=1,NHEP
6942 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
6943 XF = ABS(PHEP(3,K)/EEN)
6944 IF(XF.LT.PARMDL(72)) GOTO 150
6945* ISTHEP(K) = 2
6946 GOTO 261
6947 ENDIF
6948 260 CONTINUE
6949 261 CONTINUE
6950C
6951C statistics
6952 NITERS(ISIDE) = NITERS(ISIDE)+1
6953 IF(ISIDE.EQ.1) THEN
6954 AY1 = AY1+Y1
6955 AYS1 = AYS1+Y1*Y1
6956 Q21AVE = Q21AVE+Q2P1
6957 Q21AV2 = Q21AV2+Q2P1*Q2P1
6958 Q21MIN = MIN(Q21MIN,Q2P1)
6959 Q21MAX = MAX(Q21MAX,Q2P1)
6960 YY1MIN = MIN(YY1MIN,Y1)
6961 YY1MAX = MAX(YY1MAX,Y1)
6962 ELSE
6963 AY2 = AY2+Y2
6964 AYS2 = AYS2+Y2*Y2
6965 Q22AVE = Q22AVE+Q2P2
6966 Q22AV2 = Q22AV2+Q2P2*Q2P2
6967 Q22MIN = MIN(Q22MIN,Q2P2)
6968 Q22MAX = MAX(Q22MAX,Q2P2)
6969 YY2MIN = MIN(YY2MIN,Y2)
6970 YY2MAX = MAX(YY2MAX,Y2)
6971 ENDIF
6972C histograms
6973 CALL PHO_PHIST(1,HSWGHT(0))
6974 CALL PHO_LHIST(1,HSWGHT(0))
6975 200 CONTINUE
6976C
6977 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
6978 WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
6979 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
6980 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
6981 AY1 = AY1/DBLE(MAX(NITERS(1),1))
6982 AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
6983 DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
6984 AY2 = AY2/DBLE(MAX(NITERS(2),1))
6985 AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
6986 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
6987 Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
6988 Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
6989 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
6990 Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
6991 Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
6992 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
6993 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
6994 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
6995 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
6996C output of statistics, histograms
6997 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
6998 &'=========================================================',
6999 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7000 &'========================================================='
7001 WRITE(LO,'(//1X,A,/3X,6I12)')
7002 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
7003 & NITER,NITERS,ITRY,ITRW
7004 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7005 & WGY,WEIGHT
7006 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
7007 & AY1,DAY1
7008 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7009 & AY2,DAY2
7010 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
7011 & YY1MIN,YY1MAX
7012 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7013 & YY2MIN,YY2MAX
7014 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
7015 & Q21AVE,Q21AV2
7016 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
7017 & Q21MIN,Q21MAX
7018 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7019 & Q22AVE,Q22AV2
7020 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7021 & Q22MIN,Q22MAX
7022C
7023 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7024 IF(NITER.GT.1) THEN
7025 CALL PHO_PHIST(-2,WEIGHT)
7026 CALL PHO_LHIST(-2,WEIGHT)
7027 ELSE
7028 WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7029 ENDIF
7030
7031 END
7032
7033*$ CREATE PHO_GHHIAS.FOR
7034*COPY PHO_GHHIAS
7035CDECK ID>, PHO_GHHIAS
7036 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7037C**********************************************************************
7038C
7039C interface to call PHOJET (variable energy run) for
7040C gamma-hadron collisions in heavy ion - hadron
7041C collisions (form factor approach)
7042C
7043C input: EEP LAB system energy of proton (GeV)
7044C EEN LAB system energy per nucleon (GeV)
7045C NA atomic number of ion/hadron
7046C NZ charge number of ion/hadron
7047C NEVENT number of events to generate
7048C from /LEPCUT/:
7049C YMIN2 lower limit of Y
7050C (energy fraction taken by photon from hadron)
7051C YMAX2 upper cutoff for Y, necessary to avoid
7052C underflows
7053C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7054C Q2MAX2 maximum Q**2 of photons (if necessary,
7055C corrected according size of hadron)
7056C
7057C**********************************************************************
7058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7059 SAVE
7060
7061 PARAMETER ( PI = 3.14159265359D0 )
7062
7063C input/output channels
7064 INTEGER LI,LO
7065 COMMON /POINOU/ LI,LO
7066C model switches and parameters
7067 CHARACTER*8 MDLNA
7068 INTEGER ISWMDL,IPAMDL
7069 DOUBLE PRECISION PARMDL
7070 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7071C event debugging information
7072 INTEGER NMAXD
7073 PARAMETER (NMAXD=100)
7074 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7075 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7076 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7077 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7078C photon flux kinematics and cuts
7079 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7080 & YMIN1,YMAX1,YMIN2,YMAX2,
7081 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7082 & THMIN1,THMAX1,THMIN2,THMAX2
7083 INTEGER ITAG1,ITAG2
7084 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7085 & YMIN1,YMAX1,YMIN2,YMAX2,
7086 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7087 & THMIN1,THMAX1,THMIN2,THMAX2,
7088 & ITAG1,ITAG2
7089C gamma-lepton or gamma-hadron vertex information
7090 INTEGER IGHEL,IDPSRC,IDBSRC
7091 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7092 & RADSRC,AMSRC,GAMSRC
7093 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7094 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7095 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7096C nucleon-nucleus / nucleus-nucleus interface to DPMJET
7097 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7098 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7099 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7100 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7101C standard particle data interface
7102 INTEGER NMXHEP
7103 PARAMETER (NMXHEP=4000)
7104 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7105 DOUBLE PRECISION PHEP,VHEP
7106 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7107 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7108 & VHEP(4,NMXHEP)
7109C extension to standard particle data interface (PHOJET specific)
7110 INTEGER IMPART,IPHIST,ICOLOR
7111 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7112C event weights and generated cross section
7113 INTEGER IPOWGC,ISWCUT,IVWGHT
7114 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7115 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7116 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7117
7118 DIMENSION P1(4),P2(4)
7119
7120 WRITE(LO,'(2(/1X,A))')
7121 & 'PHO_GHHIAS: hadron-gamma event generation',
7122 & '-----------------------------------------'
7123C hadron size and mass
7124 FM2GEV = 5.07D0
7125 HIMASS = DBLE(NA)*0.938D0
7126 HIMA2 = HIMASS**2
7127 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7128 ALPHA = DBLE(NZ**2)/137.D0
7129 AMP = 0.938D0
7130 AMP2 = AMP**2
7131C correct Q2MAX2 according to hadron size
7132 Q2MAXH = 2.D0/HIRADI**2
7133 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7134 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7135C total hadron / heavy ion energy
7136 EE = EEN*DBLE(NA)
7137 GAMMA = EE/HIMASS
7138C setup /POFSRC/
7139 GAMSRC(2) = GAMMA
7140 RADSRC(2) = HIRADI
7141 AMSRC(2) = HIMASS
7142C check kinematic limitations
7143 YMI = ECMIN**2/(4.D0*EE*EEP)
7144 IF(YMIN2.LT.YMI) THEN
7145 WRITE(LO,'(/1X,A,2E12.5)')
7146 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7147 YMIN2 = YMI
7148 ELSE IF(YMIN2.GT.YMI) THEN
7149 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7150 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7151 & ' INSTEAD OF',YMIN2
7152 ENDIF
7153C kinematic limitation
7154 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7155C debug output
7156 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
7157 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
7158 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
7159 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7160 & Q2MAX2
7161 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
7162 & YMAX2
7163 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
7164 & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7165 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
7166 & ECMAX
7167 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
7168 IF(Q2LOW2.GE.Q2MAX2) THEN
7169 WRITE(LO,'(/1X,A,2E12.4)')
7170 & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7171 CALL PHO_ABORT
7172 ENDIF
7173C hadron numbers set to 0
7174 IDPSRC(1) = 0
7175 IDPSRC(2) = 0
7176 IDBSRC(1) = 0
7177 IDBSRC(2) = 0
7178C
7179 Max_tab = 100
7180 YMAX = YMAX2
7181 YMIN = YMIN2
7182 XMAX = LOG(YMAX)
7183 XMIN = LOG(YMIN)
7184 XDEL = XMAX-XMIN
7185 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7186 DO 102 I=1,Max_tab
7187 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7188 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7189 IF(Q2LOW2.GE.Q2MAX2) THEN
7190 WRITE(LO,'(/1X,A,2E12.4)')
7191 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7192 YMAX2 = MIN(Y1,YMAX2)
7193 GOTO 103
7194 ENDIF
7195 102 CONTINUE
7196 103 CONTINUE
7197C
7198 X2MAX = LOG(YMAX2)
7199 X2MIN = LOG(YMIN2)
7200 X2DEL = X2MAX-X2MIN
7201 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7202 FLUX = 0.D0
7203 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7204 & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7205 DO 105 I=1,Max_tab
7206 Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7207 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7208 FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7209 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7210 FLUX = FLUX+Y2*FF
7211 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7212 105 CONTINUE
7213 FLUX = FLUX*DELLY
7214 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7215 & 'PHO_GHHIAS: integrated flux:',FLUX
7216C
7217C hadron
7218 P1(1) = 0.D0
7219 P1(2) = 0.D0
7220 P1(3) = -SQRT(EEP**2-AMP2)
7221 P1(4) = EEP
7222C photon
7223 EGAM = YMAX2*EE
7224 P2(1) = 0.D0
7225 P2(2) = 0.D0
7226 P2(3) = EGAM
7227 P2(4) = EGAM
7228 CALL PHO_SETPAR(1,2212,0,0.D0)
7229 CALL PHO_SETPAR(2,22,0,0.D0)
7230 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7231C
7232 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7233 Y2 = YMIN2
7234 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7235 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7236C
7237 CALL PHO_PHIST(-1,SIGMAX)
7238 CALL PHO_LHIST(-1,SIGMAX)
7239C
7240C generation of events, flux calculation
7241 AY1 = 0.D0
7242 AY2 = 0.D0
7243 AYS1 = 0.D0
7244 AYS2 = 0.D0
7245 Q22MIN = 1.D30
7246 Q22MAX = 0.D0
7247 Q22AVE = 0.D0
7248 Q22AV2 = 0.D0
7249 YY2MIN = 1.D30
7250 YY2MAX = 0.D0
7251 NITER = NEVENT
7252 NITERS = 0
7253 ITRY = 0
7254 ITRW = 0
7255 DO 200 I=1,NITER
7256C sample photon flux
7257 150 CONTINUE
7258 ITRY = ITRY+1
7259 175 CONTINUE
7260C
7261 ITRW = ITRW+1
7262C select Y2
7263 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7264 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7265 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7266 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7267 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7268 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7269 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7270 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7271 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7272C sample Q2
7273 IF(IPAMDL(174).EQ.1) THEN
7274 YEFF = 1.D0+(1.D0-Y2)**2
7275 186 CONTINUE
7276 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7277 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7278 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7279 ELSE
7280 Q2P2 = Q2LOW2
7281 ENDIF
7282C impact parameter
7283 GAIMP(2) = 1.D0/SQRT(Q2P2)
7284C form factor (squared)
7285 FF2 = 1.D0
7286 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7287 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7288C photon data
7289 GYY(2) = Y2
7290 GQ2(2) = Q2P2
7291C
7292C incoming hadron 1
7293 PINI(1,1) = 0.D0
7294 PINI(2,1) = 0.D0
7295 PINI(3,1) = SQRT(EEP**2-AMP2)
7296 PINI(4,1) = EEP
7297 PINI(5,1) = AMP
7298C incoming hadron 2
7299 PINI(1,2) = 0.D0
7300 PINI(2,2) = 0.D0
7301 PINI(3,2) = -SQRT(EE**2-AMP2)
7302 PINI(4,2) = EE
7303 PINI(5,2) = AMP
7304C outgoing hadron 2
7305 YQ2 = SQRT((1.D0-Y2)*Q2P2)
7306 Q2E = Q2P2/(4.D0*EE)
7307 E1Y = EE*(1.D0-Y2)
7308 CALL PHO_SFECFE(SIF,COF)
7309 PFIN(1,2) = YQ2*COF
7310 PFIN(2,2) = YQ2*SIF
7311 PFIN(3,2) = -E1Y+Q2E
7312 PFIN(4,2) = E1Y+Q2E
7313 PFIN(5,2) = 0.D0
7314 PFPHI(2) = ATAN2(COF,SIF)
7315 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7316C scattering hadron
7317 P1(1) = 0.D0
7318 P1(2) = 0.D0
7319 P1(3) = SQRT(EEP**2-AMP2)
7320 P1(4) = EEP
7321 Q2P1 = AMP2
7322C scattering photon
7323 P2(1) = -PFIN(1,2)
7324 P2(2) = -PFIN(2,2)
7325 P2(3) = PINI(3,2)-PFIN(3,2)
7326 P2(4) = PINI(4,2)-PFIN(4,2)
7327 ISIDE = 2
7328C
7329C ECMS cut
7330 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7331 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7332 IF(GGECM.LT.0.1D0) GOTO 175
7333 GGECM = SQRT(GGECM)
7334 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7335C
7336 PGAM(1,1) = P1(1)
7337 PGAM(2,1) = P1(2)
7338 PGAM(3,1) = P1(3)
7339 PGAM(4,1) = P1(4)
7340 PGAM(5,1) = AMP
7341 PGAM(1,2) = P2(1)
7342 PGAM(2,2) = P2(2)
7343 PGAM(3,2) = P2(3)
7344 PGAM(4,2) = P2(4)
7345 PGAM(5,2) = -SQRT(Q2P2)
7346C photon helicities
7347 IGHEL(2) = 1
7348C user cuts
7349 CALL PHO_PRESEL(5,IREJ)
7350 IF(IREJ.NE.0) GOTO 175
7351C event generation
7352 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7353 IF(IREJ.NE.0) GOTO 150
7354C cut on diffractive mass
7355 DO 250 K=1,NHEP
7356 IF(ISTHEP(K).EQ.30) THEN
7357 GHDIFF = PHEP(1,K)
7358 IF(GHDIFF.GE.PARMDL(175)) THEN
7359 GOTO 251
7360 ELSE
7361 GOTO 150
7362 ENDIF
7363 ENDIF
7364 250 CONTINUE
7365 WRITE(LO,'(/,1X,A)')
7366 & 'PHO_GHHIOF: no diffractive entry found'
7367 CALL PHO_PREVNT(-1)
7368 GOTO 150
7369 251 CONTINUE
7370C remove quasi-elastically scattered hadron
7371 DO 260 K=1,NHEP
7372 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7373 XF = ABS(PHEP(3,K)/EEN)
7374 IF(XF.LT.PARMDL(72)) GOTO 150
7375* ISTHEP(K) = 2
7376 GOTO 261
7377 ENDIF
7378 260 CONTINUE
7379 261 CONTINUE
7380C
7381C statistics
7382 NITERS = NITERS+1
7383 AY2 = AY2+Y2
7384 AYS2 = AYS2+Y2*Y2
7385 Q22AVE = Q22AVE+Q2P2
7386 Q22AV2 = Q22AV2+Q2P2*Q2P2
7387 Q22MIN = MIN(Q22MIN,Q2P2)
7388 Q22MAX = MAX(Q22MAX,Q2P2)
7389 YY2MIN = MIN(YY2MIN,Y2)
7390 YY2MAX = MAX(YY2MAX,Y2)
7391C histograms
7392 CALL PHO_PHIST(1,HSWGHT(0))
7393 CALL PHO_LHIST(1,HSWGHT(0))
7394 200 CONTINUE
7395C
7396 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7397 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7398 AY2 = AY2/DBLE(MAX(NITERS,1))
7399 AYS2 = AYS2/DBLE(MAX(NITERS,1))
7400 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7401 Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7402 Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7403 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7404 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7405 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7406 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7407C output of statistics, histograms
7408 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7409 &'=========================================================',
7410 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7411 &'========================================================='
7412 WRITE(LO,'(//1X,A,/3X,4I12)')
7413 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
7414 & NITER,NITERS,ITRY,ITRW
7415 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7416 & WGY,WEIGHT
7417 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7418 & AY2,DAY2
7419 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7420 & YY2MIN,YY2MAX
7421 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7422 & Q22AVE,Q22AV2
7423 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7424 & Q22MIN,Q22MAX
7425C
7426 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7427 IF(NITER.GT.1) THEN
7428 CALL PHO_PHIST(-2,WEIGHT)
7429 CALL PHO_LHIST(-2,WEIGHT)
7430 ELSE
7431 WRITE(LO,'(1X,A,I4)')
7432 & 'PHO_GHHIOF: no output of histograms',NITER
7433 ENDIF
7434
7435 END
7436
7437*$ CREATE PHO_FITPAR.FOR
7438*COPY PHO_FITPAR
7439CDECK ID>, PHO_FITPAR
7440 SUBROUTINE PHO_FITPAR(IOUTP)
7441C**********************************************************************
7442C
7443C read input parameters according to PDFs
7444C
7445C**********************************************************************
7446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7447 SAVE
7448
7449 PARAMETER ( DEFA=-99999.D0,
7450 & DEFB=-100000.D0,
7451 & THOUS=1.D3)
7452
7453C input/output channels
7454 INTEGER LI,LO
7455 COMMON /POINOU/ LI,LO
7456C event debugging information
7457 INTEGER NMAXD
7458 PARAMETER (NMAXD=100)
7459 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7460 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7461 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7462 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7463C model switches and parameters
7464 CHARACTER*8 MDLNA
7465 INTEGER ISWMDL,IPAMDL
7466 DOUBLE PRECISION PARMDL
7467 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7468C global event kinematics and particle IDs
7469 INTEGER IFPAP,IFPAB
7470 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7471 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7472C currently activated parton density parametrizations
7473 CHARACTER*8 PDFNAM
7474 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7475 DOUBLE PRECISION PDFLAM,PDFQ2M
7476 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7477 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7478C Reggeon phenomenology parameters
7479 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7480 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7481 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7482 & ALREG,ALREGP,GR(2),B0REG(2),
7483 & GPPP,GPPR,B0PPP,B0PPR,
7484 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7485C parameters of 2x2 channel model
7486 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7487 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7488
7489 DIMENSION INUM(3),IFPAS(2)
7490 CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7491 CHARACTER*10 CNAM10
7492
7493 PARAMETER ( Max_tab = 22 )
7494 DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7495 REAL XDPtab
7496 INTEGER IDPtab
7497
7498C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
7499 DATA (IDPtab(k, 1),k=1,8) /
7500 & 2212, 5, 6, 0, 2212, 5, 6, 0 /
7501 DATA (XDPtab(k, 1),k=1,27) /
7502 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7503 &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7504 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7505 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7506 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7507
7508C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
7509 DATA (IDPtab(k, 2),k=1,8) /
7510 & 2212, 5, 6, 0, -2212, 5, 6, 0 /
7511 DATA (XDPtab(k, 2),k=1,27) /
7512 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7513 &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7514 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7515 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7516 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7517
7518C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
7519 DATA (IDPtab(k, 3),k=1,8) /
7520 & 22, 5, 3, 0, 2212, 5, 6, 0 /
7521 DATA (XDPtab(k, 3),k=1,27) /
7522 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7523 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7524 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7525 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7526 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7527
7528C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
7529 DATA (IDPtab(k, 4),k=1,8) /
7530 & 22, 5, 3, 0, 22, 5, 3, 0 /
7531 DATA (XDPtab(k, 4),k=1,27) /
7532 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7533 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7534 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7535 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7536 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7537
7538C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
7539 DATA (IDPtab(k, 5),k=1,8) /
7540 & 22, 5, 4, 4, 2212, 5, 6, 0 /
7541 DATA (XDPtab(k, 5),k=1,27) /
7542 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7543 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7544 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7545 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7546 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7547
7548C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
7549 DATA (IDPtab(k, 6),k=1,8) /
7550 & 22, 5, 4, 4, 22, 5, 4, 4 /
7551 DATA (XDPtab(k, 6),k=1,27) /
7552 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7553 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7554 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7555 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7556 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7557
7558C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
7559 DATA (IDPtab(k, 7),k=1,8) /
7560 & 22, 1, 1, 4, 22, 1, 1, 4 /
7561 DATA (XDPtab(k, 7),k=1,27) /
7562 &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7563 &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7564 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7565 &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7566 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7567
7568C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
7569 DATA (IDPtab(k, 8),k=1,8) /
7570 & 22, 1, 2, 4, 22, 1, 2, 4 /
7571 DATA (XDPtab(k, 8),k=1,27) /
7572 &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7573 &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7574 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7575 &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7576 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7577
7578C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
7579 DATA (IDPtab(k, 9),k=1,8) /
7580 & 22, 1, 3, 4, 22, 1, 3, 4 /
7581 DATA (XDPtab(k, 9),k=1,27) /
7582 &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7583 &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7584 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7585 &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7586 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7587
7588C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
7589 DATA (IDPtab(k, 10),k=1,8) /
7590 & 22, 1, 4, 4, 22, 1, 4, 4 /
7591 DATA (XDPtab(k, 10),k=1,27) /
7592 &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7593 &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7594 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7595 &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7596 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7597
7598C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7599 DATA (IDPtab(k, 11),k=1,8) /
7600 & 22, 3, 1, 3, 2212, 5, 6, 0 /
7601 DATA (XDPtab(k, 11),k=1,27) /
7602 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7603 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7604 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7605 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7606 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7607
7608C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7609 DATA (IDPtab(k, 12),k=1,8) /
7610 & 22, 3, 1, 2, 2212, 5, 6, 0 /
7611 DATA (XDPtab(k, 12),k=1,27) /
7612 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7613 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7614 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7615 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7616 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7617
7618C parameter set for 22 (LAC ) 22 (LAC )
7619 DATA (IDPtab(k, 13),k=1,8) /
7620 & 22, 3, 1, 3, 22, 3, 1, 3 /
7621 DATA (XDPtab(k, 13),k=1,27) /
7622 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7623 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7624 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7625 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7626 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7627
7628C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7629 DATA (IDPtab(k, 14),k=1,8) /
7630 & 22, 3, 1, 2, 22, 3, 1, 2 /
7631 DATA (XDPtab(k, 14),k=1,27) /
7632 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7633 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7634 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7635 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7636 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7637
7638C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7639 DATA (IDPtab(k, 15),k=1,8) /
7640 & 22, 3, 2, 3, 2212, 5, 6, 0 /
7641 DATA (XDPtab(k, 15),k=1,27) /
7642 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7643 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7644 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7645 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7646 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7647
7648C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7649 DATA (IDPtab(k, 16),k=1,8) /
7650 & 22, 3, 2, 2, 2212, 5, 6, 0 /
7651 DATA (XDPtab(k, 16),k=1,27) /
7652 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7653 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7654 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7655 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7656 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7657
7658C parameter set for 22 (LAC ) 22 (LAC )
7659 DATA (IDPtab(k, 17),k=1,8) /
7660 & 22, 3, 2, 3, 22, 3, 2, 3 /
7661 DATA (XDPtab(k, 17),k=1,27) /
7662 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7663 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7664 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7665 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7666 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7667
7668C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7669 DATA (IDPtab(k, 18),k=1,8) /
7670 & 22, 3, 2, 2, 22, 3, 2, 2 /
7671 DATA (XDPtab(k, 18),k=1,27) /
7672 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7673 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7674 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7675 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7676 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7677
7678C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7679 DATA (IDPtab(k, 19),k=1,8) /
7680 & 22, 3, 3, 3, 2212, 5, 6, 0 /
7681 DATA (XDPtab(k, 19),k=1,27) /
7682 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7683 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7684 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7685 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7686 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7687
7688C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7689 DATA (IDPtab(k, 20),k=1,8) /
7690 & 22, 3, 3, 2, 2212, 5, 6, 0 /
7691 DATA (XDPtab(k, 20),k=1,27) /
7692 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7693 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7694 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7695 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7696 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7697
7698C parameter set for 22 (LAC ) 22 (LAC )
7699 DATA (IDPtab(k, 21),k=1,8) /
7700 & 22, 3, 3, 3, 22, 3, 3, 3 /
7701 DATA (XDPtab(k, 21),k=1,27) /
7702 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7703 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7704 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7705 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7706 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7707
7708C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7709 DATA (IDPtab(k, 22),k=1,8) /
7710 & 22, 3, 3, 2, 22, 3, 3, 2 /
7711 DATA (XDPtab(k, 22),k=1,27) /
7712 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7713 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7714 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7715 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7716 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7717
7718 DATA CNAME8 /' '/
7719 DATA CNAM10 /' '/
7720 DATA INIT / 0 /
7721 DATA IFPAS / 0, 0 /
7722
7723 IF((INIT.EQ.1).AND.
7724 & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7725
7726 INIT=1
7727 IFPAS(1) = IFPAP(1)
7728 IFPAS(2) = IFPAP(2)
7729
7730C parton distribution functions
7731 CALL PHO_ACTPDF(IFPAP(1),1)
7732 CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7733 CALL PHO_ACTPDF(IFPAP(2),2)
7734 CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7735C initialize alpha_s calculation
7736 DUMMY = PHO_ALPHAS(0.D0,-4)
7737
7738 IF(IDEB(54).GE.0) THEN
7739 WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7740 & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7741 WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7742 & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7743 ENDIF
7744
7745 IFOUND = 0
7746
7747C load parameter set from internal tables
7748 I1 = 1
7749 I2 = 2
7750 110 CONTINUE
7751
7752 DO I=1,Max_tab
7753 IF((IFPAP(I1).EQ.IDPtab(1,I))
7754 & .AND.(IGRP(I1).EQ.IDPtab(2,I))
7755 & .AND.(ISET(I1).EQ.IDPtab(3,I))
7756 & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7757 IF((IFPAP(I2).EQ.IDPtab(5,I))
7758 & .AND.(IGRP(I2).EQ.IDPtab(6,I))
7759 & .AND.(ISET(I2).EQ.IDPtab(7,I))
7760 & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7761 WRITE(LO,'(/1X,A)')
7762 & 'PHO_FITPAR: parameter set found in internal table'
7763 ALPOM = XDPtab(1,I)
7764 ALPOMP = XDPtab(2,I)
7765 GP(I1) = XDPtab(3,I)
7766 GP(I2) = XDPtab(4,I)
7767 B0POM(I1) = XDPtab(5,I)
7768 B0POM(I2) = XDPtab(6,I)
7769 ALREG = XDPtab(7,I)
7770 ALREGP = XDPtab(8,I)
7771 GR(I1) = XDPtab(9,I)
7772 GR(I2) = XDPtab(10,I)
7773 B0REG(I1) = XDPtab(11,I)
7774 B0REG(I2) = XDPtab(12,I)
7775 GPPP = XDPtab(13,I)
7776 B0PPP = XDPtab(14,I)
7777 GPPR = XDPtab(15,I)
7778 B0PPR = XDPtab(16,I)
7779 VDMFAC(2*I1-1) = XDPtab(17,I)
7780 VDMFAC(2*I1) = XDPtab(18,I)
7781 VDMFAC(2*I2-1) = XDPtab(19,I)
7782 VDMFAC(2*I2) = XDPtab(20,I)
7783 B0HAR = XDPtab(21,I)
7784 AKFAC = XDPtab(22,I)
7785 PHISUP(I1) = XDPtab(23,I)
7786 PHISUP(I2) = XDPtab(24,I)
7787 RMASS(I1) = XDPtab(25,I)
7788 RMASS(I2) = XDPtab(26,I)
7789 VAR = XDPtab(27,I)
7790 IFOUND = 1
7791 GOTO 1200
7792 ENDIF
7793 ENDIF
7794 ENDDO
7795
7796 IF(I1.EQ.1) THEN
7797 I1 = 2
7798 I2 = 1
7799 GOTO 110
7800 ELSE
7801 WRITE(LO,'(/1X,A)')
7802 & 'PHO_FITPAR: parameter set not found in internal table'
7803 ENDIF
7804
7805 1200 CONTINUE
7806
7807C get parameters of soft cross sections from fitpar.dat
7808 IF(IPAMDL(99).GT.IFOUND) THEN
7809
7810 WRITE(LO,'(/1X,A)')
7811 & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
7812 OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7813
7814 100 CONTINUE
7815 READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7816 IF(CNAME8.EQ.'STOP') GOTO 1010
7817 IF(CNAME8.EQ.'NEXTDATA') THEN
7818 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7819 & IDPA1,CNAME8,INUM
7820 IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7821 & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7822 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7823 & IDPA2,CNAME8,INUM
7824 IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7825 & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7826 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7827 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7828 READ(12,*) ALREG,ALREGP,GR,B0REG
7829 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7830 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7831 READ(12,*) B0HAR
7832 READ(12,*) AKFAC
7833 READ(12,*) PHISUP
7834 READ(12,*) RMASS,VAR
7835 IFOUND = 1
7836 GOTO 1100
7837 ENDIF
7838 ENDIF
7839 ENDIF
7840 GOTO 100
7841
7842 1020 CONTINUE
7843 WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7844 WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7845 1010 CONTINUE
7846 WRITE(LO,'(/A)')
7847 & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7848
7849 1100 CONTINUE
7850 CLOSE(12)
7851
7852 ENDIF
7853
7854C nothing found
7855 IF(IFOUND.EQ.0) THEN
7856 WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7857 WRITE(LO,'(3(10X,A,/))')
7858 & '(copy fitpar.dat into the working directory and/or',
7859 & ' request the missing parameter set via e-mail from',
7860 & ' ralph.engel@fzk.de)'
7861 STOP
7862 ENDIF
7863
7864 1300 CONTINUE
7865
7866C overwrite parameters with user settings
7867 IF(PARMDL(301).GT.DEFA) THEN
7868 ALPOM = PARMDL(301)
7869 PARMDL(301) = DEFB
7870 ENDIF
7871 IF(PARMDL(302).GT.DEFA) THEN
7872 ALPOMP = PARMDL(302)
7873 PARMDL(302) = DEFB
7874 ENDIF
7875 IF(PARMDL(303).GT.DEFA) THEN
7876 GP(1) = PARMDL(303)
7877 PARMDL(303) = DEFB
7878 ENDIF
7879 IF(PARMDL(304).GT.DEFA) THEN
7880 GP(2) = PARMDL(304)
7881 PARMDL(304) = DEFB
7882 ENDIF
7883 IF(PARMDL(305).GT.DEFA) THEN
7884 B0POM(1) = PARMDL(305)
7885 PARMDL(305) = DEFB
7886 ENDIF
7887 IF(PARMDL(306).GT.DEFA) THEN
7888 B0POM(2) = PARMDL(306)
7889 PARMDL(306) = DEFB
7890 ENDIF
7891 IF(PARMDL(307).GT.DEFA) THEN
7892 ALREG = PARMDL(307)
7893 PARMDL(307) = DEFB
7894 ENDIF
7895 IF(PARMDL(308).GT.DEFA) THEN
7896 ALREGP = PARMDL(308)
7897 PARMDL(308) = DEFB
7898 ENDIF
7899 IF(PARMDL(309).GT.DEFA) THEN
7900 GR(1) = PARMDL(309)
7901 PARMDL(309) = DEFB
7902 ENDIF
7903 IF(PARMDL(310).GT.DEFA) THEN
7904 GR(2) = PARMDL(310)
7905 PARMDL(310) = DEFB
7906 ENDIF
7907 IF(PARMDL(311).GT.DEFA) THEN
7908 B0REG(1) = PARMDL(311)
7909 PARMDL(311) = DEFB
7910 ENDIF
7911 IF(PARMDL(312).GT.DEFA) THEN
7912 B0REG(2) = PARMDL(312)
7913 PARMDL(312) = DEFB
7914 ENDIF
7915 IF(PARMDL(313).GT.DEFA) THEN
7916 GPPP = PARMDL(313)
7917 PARMDL(313) = DEFB
7918 ENDIF
7919 IF(PARMDL(314).GT.DEFA) THEN
7920 B0PPP = PARMDL(314)
7921 PARMDL(314)= DEFB
7922 ENDIF
7923 IF(PARMDL(315).GT.DEFA) THEN
7924 VDMFAC(1) = PARMDL(315)
7925 PARMDL(315)= DEFB
7926 ENDIF
7927 IF(PARMDL(316).GT.DEFA) THEN
7928 VDMFAC(2) = PARMDL(316)
7929 PARMDL(316)= DEFB
7930 ENDIF
7931 IF(PARMDL(317).GT.DEFA) THEN
7932 VDMFAC(3) = PARMDL(317)
7933 PARMDL(317)= DEFB
7934 ENDIF
7935 IF(PARMDL(318).GT.DEFA) THEN
7936 VDMFAC(4) = PARMDL(318)
7937 PARMDL(318)= DEFB
7938 ENDIF
7939 IF(PARMDL(319).GT.DEFA) THEN
7940 B0HAR = PARMDL(319)
7941 PARMDL(319)= DEFB
7942 ENDIF
7943 IF(PARMDL(320).GT.DEFA) THEN
7944 AKFAC = PARMDL(320)
7945 PARMDL(320)= DEFB
7946 ENDIF
7947 IF(PARMDL(321).GT.DEFA) THEN
7948 PHISUP(1) = PARMDL(321)
7949 PARMDL(321)= DEFB
7950 ENDIF
7951 IF(PARMDL(322).GT.DEFA) THEN
7952 PHISUP(2) = PARMDL(322)
7953 PARMDL(322)= DEFB
7954 ENDIF
7955 IF(PARMDL(323).GT.DEFA) THEN
7956 RMASS(1) = PARMDL(323)
7957 PARMDL(323)= DEFB
7958 ENDIF
7959 IF(PARMDL(324).GT.DEFA) THEN
7960 RMASS(2) = PARMDL(324)
7961 PARMDL(324)= DEFB
7962 ENDIF
7963 IF(PARMDL(325).GT.DEFA) THEN
7964 VAR = PARMDL(325)
7965 PARMDL(325)= DEFB
7966 ENDIF
7967 IF(PARMDL(327).GT.DEFA) THEN
7968 GPPR = PARMDL(327)
7969 PARMDL(327)= DEFB
7970 ENDIF
7971 IF(PARMDL(328).GT.DEFA) THEN
7972 B0PPR = PARMDL(328)
7973 PARMDL(328)= DEFB
7974 ENDIF
7975
7976 VDMQ2F(1) = VDMFAC(1)
7977 VDMQ2F(2) = VDMFAC(2)
7978 VDMQ2F(3) = VDMFAC(3)
7979 VDMQ2F(4) = VDMFAC(4)
7980
7981C output of parameter set
7982 IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
7983 WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
7984 & ' -------------------------'
7985 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7986 & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
7987 & B0POM
7988 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7989 & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
7990 & B0REG
7991 WRITE(LO,'(4(A,F7.3))')
7992 & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
7993 WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
7994 WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
7995 WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
7996 WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
7997 WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
7998 WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
7999 ENDIF
8000
8001 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8002
8003 END
8004
8005*$ CREATE PHO_BORNCS.FOR
8006*COPY PHO_BORNCS
8007CDECK ID>, PHO_BORNCS
8008 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8009C*********************************************************************
8010C
8011C calculation of Born graph cross sections and slopes
8012C
8013C input: IP particle combination
8014C IFHARD -1 calculate hard Born graph cross section
8015C 0 take hard Born graph cross section
8016C from interpolation table if available
8017C 1 assume that correct hard cross
8018C sections are already stored in /POSBRN/
8019C XM1,XM2,XM3,XM4 masses of external lines
8020C /GLOCMS/ energy and PT cut-off
8021C /POPREG/ soft and hard parameters
8022C /POSBRN/ input cross sections
8023C /POZBRN/ scaled input values
8024C IFHARD 0 calculate hard input cross sections
8025C 1 assume hard input cross sections exist
8026C
8027C output: ZPOM scaled pomeron cross section
8028C ZIGR scaled reggeon cross section
8029C ZIGHR scaled hard resolved cross section
8030C ZIGHD scaled hard direct cross section
8031C ZIGT1 scaled triple-Pomeron cross section
8032C ZIGT2 scaled triple-Pomeron cross section
8033C ZIGL scaled loop-Pomeron cross section
8034C
8035C*********************************************************************
8036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8037 SAVE
8038
8039 PARAMETER(ITWO=2,
8040 & ITHREE=3,
8041 & IFOUR=4,
8042 & IFIVE=5,
8043 & FIVE=5.D0,
8044 & THOUS=1.D3,
8045 & EPS=0.01D0,
8046 & DEPS=1.D-30)
8047
8048C input/output channels
8049 INTEGER LI,LO
8050 COMMON /POINOU/ LI,LO
8051C some constants
8052 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8053 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8054 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8055C event debugging information
8056 INTEGER NMAXD
8057 PARAMETER (NMAXD=100)
8058 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8059 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8060 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8061 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8062C model switches and parameters
8063 CHARACTER*8 MDLNA
8064 INTEGER ISWMDL,IPAMDL
8065 DOUBLE PRECISION PARMDL
8066 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8067C names of hard scattering processes
8068 INTEGER Max_pro_1
8069 PARAMETER ( Max_pro_1 = 16 )
8070 CHARACTER*18 PROC
8071 COMMON /POHPRO/ PROC(0:Max_pro_1)
8072C hard cross sections and MC selection weights
8073 INTEGER Max_pro_2
8074 PARAMETER ( Max_pro_2 = 16 )
8075 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8076 & MH_acc_1,MH_acc_2
8077 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8078 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8079 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8080 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8081 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8082 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8083C interpolation tables for hard cross section and MC selection weights
8084 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8085 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8086 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8087 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8088 & HQ2a_tab,HQ2b_tab,HEcm_tab
8089 COMMON /POHTAB/
8090 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8091 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8092 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8093 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8094 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8095 & HEcm_tab(1:Max_tab_E,0:4),
8096 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8097C Born graph cross sections and slopes
8098 INTEGER Max_pro_3
8099 PARAMETER ( Max_pro_3 = 16 )
8100 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8101 & SIGD1,SIGD2,DSIGH
8102 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8103 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8104C scaled cross sections and slopes
8105 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8106 & ZIGD1,ZIGD2,
8107 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8108 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8109 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8110 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8111 & BD1(2),BD2(2)
8112C Reggeon phenomenology parameters
8113 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8114 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8115 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8116 & ALREG,ALREGP,GR(2),B0REG(2),
8117 & GPPP,GPPR,B0PPP,B0PPR,
8118 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8119C parameters of 2x2 channel model
8120 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8121 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8122C data of c.m. system of Pomeron / Reggeon exchange
8123 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8124 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8125 & SIDP,CODP,SIFP,COFP
8126 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8127 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8128 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8129C obsolete cut-off information
8130 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8131 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8132C data needed for soft-pt calculation
8133 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8134 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8135
8136 COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8137 & BPOM1,BPOM2,BREG1,BREG2,B0HARD
8138 DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8139 DIMENSION BT14(2),BT24(2),BD4(4)
8140 DIMENSION DSPT(0:Max_pro_2)
8141
8142 DATA XMPOM / 0.766D0 /
8143 DATA CZERO /(0.D0,0.D0)/
8144
8145 CDABS(SS) = ABS(SS)
8146 DCMPLX(X,Y) = CMPLX(X,Y)
8147
8148C debug output
8149 IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8150 & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8151C scales
8152 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8153C
8154C calculate hard input cross sections (output in mb)
8155 IF(IFHARD.NE.1) THEN
8156 IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8157C double-log interpolation
8158 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8159 DO 60 M=0,Max_pro_2
8160 DSIGH(M) = HSig(M)
8161 DSPT(M) = Hdpt(M)
8162 60 CONTINUE
8163 ELSE
8164C new calculation
8165 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8166 CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8167 ENDIF
8168C
8169C save values to calculate soft pt distribution
8170 IF(IP.EQ.1) THEN
8171 VDMQ2F(1) = VDMFAC(1)
8172 VDMQ2F(2) = VDMFAC(2)
8173 VDMQ2F(3) = VDMFAC(3)
8174 VDMQ2F(4) = VDMFAC(4)
8175 ELSE IF(IP.EQ.2) THEN
8176 VDMQ2F(1) = VDMFAC(1)
8177 VDMQ2F(2) = VDMFAC(2)
8178 VDMQ2F(3) = 1.D0
8179 VDMQ2F(4) = 0.D0
8180 ELSE IF(IP.EQ.3) THEN
8181 VDMQ2F(1) = VDMFAC(3)
8182 VDMQ2F(2) = VDMFAC(4)
8183 VDMQ2F(3) = 1.D0
8184 VDMQ2F(4) = 0.D0
8185 ELSE
8186 VDMQ2F(1) = 1.D0
8187 VDMQ2F(2) = 0.D0
8188 VDMQ2F(3) = 1.D0
8189 VDMQ2F(4) = 0.D0
8190 ENDIF
8191C VDM factors
8192 AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8193 AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8194 AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8195 AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8196 ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8197 & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8198 ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8199 ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8200 ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8201 VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8202 & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8203 DSIGHP = DSPT(9)/VFAC
8204 SIGH = DSIGH(9)/VFAC
8205C extract real part
8206 IF(IPAMDL(1).EQ.0) THEN
8207 DO 50 I=0,Max_pro_2
8208 DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8209 50 CONTINUE
8210 ENDIF
8211C write out results
8212 IF(IDEB(48).GE.15) THEN
8213 WRITE(LO,'(/1X,A,1P,2E11.3)')
8214 & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8215 DO 200 I=0,Max_pro_2
8216 WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8217 200 CONTINUE
8218 ENDIF
8219 ENDIF
8220
8221C DPMJET interface: subtract anomalous part
8222 IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8223 & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8224
8225 SCALE = CDABS(DSIGH(15))
8226 IF(SCALE.LT.DEPS) THEN
8227 SIGHD=CZERO
8228 ELSE
8229 SIGHD=DSIGH(15)
8230 ENDIF
8231 SCALE = CDABS(DSIGH(9))
8232 IF(SCALE.LT.DEPS) THEN
8233 SIGHR=CZERO
8234 ELSE
8235 SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8236 ENDIF
8237
8238C calculate soft input cross sections (output in mb)
8239 SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8240 IF(IPAMDL(1).EQ.1) THEN
8241C pomeron signature
8242 SP=SS*DCMPLX(0.D0,-1.D0)
8243C reggeon signature
8244 SR=SS*DCMPLX(0.D0,1.D0)
8245 ELSE
8246 SP=SS
8247 SR=SS
8248 ENDIF
8249C coupling constants (mb**1/2)
8250C particle dependent slopes (GeV**-2)
8251 IF(IP.EQ.1) THEN
8252 GP1 = GP(1)
8253 GP2 = GP(2)
8254 GR1 = GR(1)
8255 GR2 = GR(2)
8256 B0POM1 = B0POM(1)
8257 B0POM2 = B0POM(2)
8258 B0REG1 = B0REG(1)
8259 B0REG2 = B0REG(2)
8260 B0HARD = B0HAR
8261 RMASS1 = RMASS(1)
8262 RMASS2 = RMASS(2)
8263 ELSE IF(IP.EQ.2) THEN
8264 GP1 = GP(1)
8265 GP2 = PARMDL(77)
8266 GR1 = GR(1)
8267 GR2 = PARMDL(77)*GPPR/GPPP
8268 B0POM1 = B0POM(1)
8269 B0POM2 = B0PPP
8270 B0REG1 = B0REG(1)
8271 B0REG2 = B0PPR
8272 B0HARD = B0POM1+B0POM2
8273 RMASS1 = RMASS(1)
8274 RMASS2 = XMPOM
8275 ELSE IF(IP.EQ.3) THEN
8276 GP1 = GP(2)
8277 GP2 = PARMDL(77)
8278 GR1 = GR(2)
8279 GR2 = PARMDL(77)*GPPR/GPPP
8280 B0POM1 = B0POM(2)
8281 B0POM2 = B0PPP
8282 B0REG1 = B0REG(2)
8283 B0REG2 = B0PPR
8284 B0HARD = B0POM1+B0POM2
8285 RMASS1 = RMASS(2)
8286 RMASS2 = XMPOM
8287 ELSE IF(IP.EQ.4) THEN
8288 GP1 = PARMDL(77)
8289 GP2 = GP1
8290 GR1 = PARMDL(77)*GPPR/GPPP
8291 GR2 = GR1
8292 B0POM1 = B0PPP
8293 B0POM2 = B0PPP
8294 B0REG1 = B0PPR
8295 B0REG2 = B0PPR
8296 B0HARD = B0POM1+B0POM2
8297 RMASS1 = XMPOM
8298 RMASS2 = XMPOM
8299 ELSE
8300 WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8301 CALL PHO_ABORT
8302 ENDIF
8303 GP1 = GP1*SCALE1
8304 GP2 = GP2*SCALE2
8305 GR1 = GR1*SCALE1
8306 GR2 = GR2*SCALE2
8307C input slope parameters (GeV**-2)
8308 BPOM1 = B0POM1*SCALB1
8309 BPOM2 = B0POM2*SCALB2
8310 BREG1 = B0REG1*SCALB1
8311 BREG2 = B0REG2*SCALB2
8312C effective slopes
8313 XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8314 SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8315 BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8316 BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8317 IF(IPAMDL(9).EQ.0) THEN
8318 BHAR = B0HARD
8319 BHAD = B0HARD
8320 ELSE IF(IPAMDL(9).EQ.1) THEN
8321 BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8322 BHAD = BHAR
8323 ELSE IF(IPAMDL(9).EQ.2) THEN
8324 BHAR = BPOM1+BPOM2
8325 BHAD = BHAR
8326 ELSE
8327 BHAR = BPOM
8328 BHAD = BPOM
8329 ENDIF
8330C input cross section pomeron
8331 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8332 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8333C save value to calculate soft pt distribution
8334 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8335
8336C higher order graphs
8337 VIRT1 = PVIRTP(1)
8338 VIRT2 = PVIRTP(2)
8339C bare/renormalized intercept for enhanced graphs
8340 IF(IPAMDL(8).EQ.0) THEN
8341 DELTAP = ALPOM-1.D0
8342 ELSE
8343 DELTAP = PARMDL(48)-1.D0
8344 ENDIF
8345 SD = ECMP**2
8346 BP1 = 2.D0*BPOM1
8347 BP2 = 2.D0*BPOM2
8348C input cross section high-mass double diffraction
8349 CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8350 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8351 SIGL = DCMPLX(SIGTR,0.D0)
8352 BLOO = DCMPLX(BTR,0.D0)
8353C
8354C input cross section high mass diffraction particle 1
8355C first possibility
8356 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8357 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8358 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8359 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8360 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8361 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8362 BP1 = 2.D0*BPOM1*SCALB1
8363 BP2 = 2.D0*BPOM2*SCALB2
8364C input cross section high mass diffraction
8365 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8366 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8367 SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8368 BTR1(1) = DCMPLX(BTR,0.D0)
8369C second possibility: high-low mass double diffraction
8370 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8371 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8372 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8373 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8374 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8375 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8376 BP1 = 2.D0*BPOM1*SCALB1
8377 BP2 = 2.D0*BPOM2*SCALB2
8378C input cross section high mass diffraction
8379 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8380 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8381 SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8382 BTR1(2) = DCMPLX(BTR,0.D0)
8383C
8384C input cross section high mass diffraction particle 2
8385C first possibility
8386 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8387 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8388 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8389 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8390 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8391 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8392 BP1 = 2.D0*BPOM1*SCALB1
8393 BP2 = 2.D0*BPOM2*SCALB2
8394C input cross section high mass diffraction
8395 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8396 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8397 SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8398 BTR2(1) = DCMPLX(BTR,0.D0)
8399C second possibility: high-low mass double diffraction
8400 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8401 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8402 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8403 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8404 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8405 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8406 BP1 = 2.D0*BPOM1*SCALB1
8407 BP2 = 2.D0*BPOM2*SCALB2
8408C input cross section high mass diffraction
8409 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8410 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8411 SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8412 BTR2(2) = DCMPLX(BTR,0.D0)
8413C
8414C input cross section for loop-pomeron
8415C first possibility
8416 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8417 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8418 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8419 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8420 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8421 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8422 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8423 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8424 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8425 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8426 BP1 = BPOM1*SCALB1
8427 BP2 = BPOM2*SCALB2
8428 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8429 & SIGTX,BTX)
8430 SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8431 BDP(1) = DCMPLX(BTX,0.D0)
8432C second possibility
8433 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8434 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8435 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8436 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8437 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8438 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8439 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8440 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8441 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8442 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8443 BP1 = BPOM1*SCALB1
8444 BP2 = BPOM2*SCALB2
8445 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8446 & SIGTX,BTX)
8447 SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8448 BDP(2) = DCMPLX(BTX,0.D0)
8449C third possibility
8450 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8451 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8452 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8453 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8454 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8455 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8456 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8457 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8458 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8459 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8460 BP1 = BPOM1*SCALB1
8461 BP2 = BPOM2*SCALB2
8462 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8463 & SIGTX,BTX)
8464 SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8465 BDP(3) = DCMPLX(BTX,0.D0)
8466C fourth possibility
8467 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8468 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8469 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8470 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8471 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8472 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8473 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8474 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8475 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8476 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8477 BP1 = BPOM1*SCALB1
8478 BP2 = BPOM2*SCALB2
8479 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8480 & SIGTX,BTX)
8481 SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8482 BDP(4) = DCMPLX(BTX,0.D0)
8483C
8484C input cross section for YY-iterated triple-pomeron
8485C .....
8486C
8487C write out input cross sections
8488 IF(IDEB(48).GE.5) THEN
8489 WRITE(LO,'(2(/1X,A))')
8490 & 'Born graph input cross sections and slopes',
8491 & '------------------------------------------'
8492 WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
8493 WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8494 & XM1,XM2,XM3,XM4
8495 WRITE(LO,'(A)') ' input cross sections (millibarn):'
8496 WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
8497 WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
8498 WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
8499 WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
8500 WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
8501 WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
8502 WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
8503 WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8504 WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8505 WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8506 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8507 WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
8508 WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
8509 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8510 WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
8511 WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
8512 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8513 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8514 WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
8515 WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
8516 WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
8517 WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
8518 WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
8519 WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
8520 ENDIF
8521C
8522 BPOM = BPOM*GEV2MB
8523 BREG = BREG*GEV2MB
8524 BHAR = BHAR*GEV2MB
8525 BHAD = BHAD*GEV2MB
8526 BTR1(1) = BTR1(1)*GEV2MB
8527 BTR1(2) = BTR1(2)*GEV2MB
8528 BTR2(1) = BTR2(1)*GEV2MB
8529 BTR2(2) = BTR2(2)*GEV2MB
8530 BLOO = BLOO*GEV2MB
8531C
8532 BP4 =BPOM*4.D0
8533 BR4 =BREG*4.D0
8534 BHR4=BHAR*4.D0
8535 BHD4=BHAD*4.D0
8536 BT14(1)=BTR1(1)*4.D0
8537 BT14(2)=BTR1(2)*4.D0
8538 BT24(1)=BTR2(1)*4.D0
8539 BT24(2)=BTR2(2)*4.D0
8540 BL4 =BLOO*4.D0
8541C
8542 ZIGP = SIGP/(PI2*BP4)
8543 ZIGR = SIGR/(PI2*BR4)
8544 ZIGHR = SIGHR/(PI2*BHR4)
8545 ZIGHD = SIGHD/(PI2*BHD4)
8546 ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8547 ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8548 ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8549 ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8550 ZIGL = SIGL/(PI2*BL4)
8551 DO 20 I=1,4
8552 BDP(I) = BDP(I)*GEV2MB
8553 BD4(I) = BDP(I)*4.D0
8554 ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8555 20 CONTINUE
8556C
8557 IF(IDEB(48).GE.10) THEN
8558 WRITE(LO,'(A)') ' normalized input values:'
8559 WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
8560 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8561 WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
8562 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8563 WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
8564 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8565 WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
8566 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8567 WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
8568 WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
8569 WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
8570 WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8571 WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8572 ENDIF
8573 END
8574
8575*$ CREATE PHO_SCALES.FOR
8576*COPY PHO_SCALES
8577CDECK ID>, PHO_SCALES
8578 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8579C**********************************************************************
8580C
8581C calculation of scale factors
8582C (mass dependent couplings and slopes)
8583C
8584C input: XM1..XM4 external masses
8585C
8586C output: SCG1,SCG2 scales of coupling constants
8587C SCB1,SCB2 scales of coupling slope parameter
8588C
8589C*********************************************************************
8590 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8591 SAVE
8592
8593 PARAMETER ( EPS = 1.D-3 )
8594
8595C input/output channels
8596 INTEGER LI,LO
8597 COMMON /POINOU/ LI,LO
8598C event debugging information
8599 INTEGER NMAXD
8600 PARAMETER (NMAXD=100)
8601 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8602 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8603 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8604 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8605C Reggeon phenomenology parameters
8606 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8607 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8608 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8609 & ALREG,ALREGP,GR(2),B0REG(2),
8610 & GPPP,GPPR,B0PPP,B0PPR,
8611 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8612C parameters of 2x2 channel model
8613 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8614 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8615C data of c.m. system of Pomeron / Reggeon exchange
8616 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8617 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8618 & SIDP,CODP,SIFP,COFP
8619 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8620 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8621 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8622C model switches and parameters
8623 CHARACTER*8 MDLNA
8624 INTEGER ISWMDL,IPAMDL
8625 DOUBLE PRECISION PARMDL
8626 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8627
8628C scale factors for couplings
8629 ECMMIN = 2.D0
8630* ECMTP = 6.D0
8631 ECMTP = 1.D0
8632 IF(ABS(XM1-XM3).GT.EPS) THEN
8633 IF(ECMP.LT.ECMTP) THEN
8634 SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8635 ELSE
8636 SCG1 = PHISUP(1)
8637 ENDIF
8638 ELSE
8639 SCG1 = 1.D0
8640 ENDIF
8641 IF(ABS(XM2-XM4).GT.EPS) THEN
8642 IF(ECMP.LT.ECMTP) THEN
8643 SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8644 ELSE
8645 SCG2 = PHISUP(2)
8646 ENDIF
8647 ELSE
8648 SCG2 = 1.D0
8649 ENDIF
8650C
8651C scale factors for slope parameters
8652 IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8653 SCB1 = 1.D0
8654 SCB2 = 1.D0
8655 ELSE IF(ISWMDL(1).EQ.2) THEN
8656C rational
8657 SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8658 SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8659 ELSE IF(ISWMDL(1).GE.3) THEN
8660C symmetric gaussian
8661 SCB1 = VAR*(XM1-XM3)**2
8662 IF(SCB1.LT.25.D0) THEN
8663 SCB1 = EXP(-SCB1)
8664 ELSE
8665 SCB1 = 0.D0
8666 ENDIF
8667 SCB2 = VAR*(XM2-XM4)**2
8668 IF(SCB2.LT.25.D0) THEN
8669 SCB2 = EXP(-SCB2)
8670 ELSE
8671 SCB2 = 0.D0
8672 ENDIF
8673 ELSE
8674 WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8675 & ISWMDL(1)
8676 CALL PHO_ABORT
8677 ENDIF
8678C debug output
8679 IF(IDEB(65).GE.10) THEN
8680 WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8681 & XM1,XM2,XM3,XM4
8682 WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8683 & SCB1,SCB2,SCG1,SCG2
8684 ENDIF
8685 END
8686
8687*$ CREATE PHO_EIKON.FOR
8688*COPY PHO_EIKON
8689CDECK ID>, PHO_EIKON
8690 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8691C*********************************************************************
8692C
8693C calculation of unitarized amplitudes
8694C
8695C input: IP particle combination
8696C IFHARD -1 ignore previously calculated Born
8697C cross sections
8698C 0 calculate hard Born cross sections or
8699C take them from interpolation table
8700C (if available)
8701C 1 take hard cross sections from /POSBRN/
8702C B impact parameter (mb**(1/2))
8703C /POSBRN/ input cross sections
8704C /GLOCMS/ cm energy
8705C /POPREG/ soft and hard parameters
8706C
8707C output: /POINT4/
8708C AMPEL purely elastic amplitude
8709C AMPVM quasi-elastically vectormeson prod.
8710C AMLMSD(2) amplitudes of low mass sing. diffr.
8711C AMHMSD(2) amplitudes of high mass sing. diffr.
8712C AMLMDD amplitude of low mass double diffr.
8713C AMHMDD amplitude of high mass double diffr.
8714C
8715C*********************************************************************
8716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8717 SAVE
8718
8719 PARAMETER(ITWO=2,
8720 & ITHREE=3,
8721 & IFOUR=4,
8722 & IFIVE=5,
8723 & ISIX=6,
8724 & FIVE=5.D0,
8725 & THOUS=1.D3,
8726 & EXPMAX=70.D0,
8727 & DEPS=1.D-20)
8728
8729C input/output channels
8730 INTEGER LI,LO
8731 COMMON /POINOU/ LI,LO
8732C event debugging information
8733 INTEGER NMAXD
8734 PARAMETER (NMAXD=100)
8735 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8736 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8737 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8738 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8739C complex Born graph amplitudes used for unitarization
8740 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8741 & AMHMDD,AMPDP
8742 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8743 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8744C cross sections
8745 INTEGER IPFIL,IFAFIL,IFBFIL
8746 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8747 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8748 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8749 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8750 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8751 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8752 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8753 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8754 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8755 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8756 & IPFIL,IFAFIL,IFBFIL
8757C Born graph cross sections and slopes
8758 INTEGER Max_pro_3
8759 PARAMETER ( Max_pro_3 = 16 )
8760 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8761 & SIGD1,SIGD2,DSIGH
8762 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8763 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8764C scaled cross sections and slopes
8765 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8766 & ZIGD1,ZIGD2,
8767 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8768 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8769 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8770 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8771 & BD1(2),BD2(2)
8772C Born graph cross sections after applying diffraction model
8773 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8774 & SBOLPO,SBODPO
8775 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8776 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8777 & SBODPO(0:4,4)
8778C global event kinematics and particle IDs
8779 INTEGER IFPAP,IFPAB
8780 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8781 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8782C data of c.m. system of Pomeron / Reggeon exchange
8783 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8784 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8785 & SIDP,CODP,SIFP,COFP
8786 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8787 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8788 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8789C Reggeon phenomenology parameters
8790 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8791 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8792 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8793 & ALREG,ALREGP,GR(2),B0REG(2),
8794 & GPPP,GPPR,B0PPP,B0PPR,
8795 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8796C parameters of 2x2 channel model
8797 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8798 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8799C model switches and parameters
8800 CHARACTER*8 MDLNA
8801 INTEGER ISWMDL,IPAMDL
8802 DOUBLE PRECISION PARMDL
8803 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8804C unitarized amplitudes for different diffraction channels
8805 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8806 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8807 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8808 & ZXL,BXL
8809 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8810 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8811 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8812 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8813 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8814 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8815 & ZXL(4,4),BXL(4,4)
8816
8817 COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8818 & AUXL,AMPR,AMPO,AMPP,AMPQ
8819
8820 DIMENSION PVOLD(2)
8821
8822 DATA ELAST / 0.D0 /
8823 DATA IPOLD / -1 /
8824 DATA PVOLD / -1.D0, -1.D0 /
8825 DATA XMPOM / 0.766D0 /
8826 DATA XMVDM / 0.766D0 /
8827
8828 DCMPLX(X,Y) = CMPLX(X,Y)
8829
8830C calculation of scaled cross sections and slopes
8831
8832C test for redundant calculation
8833 IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8834 & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8835C effective particle masses, VDM assumption
8836 XMASS1 = PMASS(1)
8837 XMASS2 = PMASS(2)
8838 RMASS1 = RMASS(1)
8839 RMASS2 = RMASS(2)
8840 IF(IFPAP(1).EQ.22) THEN
8841 XMASS1 = XMVDM
8842 ELSE IF(IFPAP(1).EQ.990) THEN
8843 XMASS1 = XMPOM
8844 ENDIF
8845 IF(IFPAP(2).EQ.22) THEN
8846 XMASS2 = XMVDM
8847 ELSE IF(IFPAP(2).EQ.990) THEN
8848 XMASS2 = XMPOM
8849 ENDIF
8850C different particle combinations
8851 IF(IP.EQ.3) THEN
8852 XMASS1 = XMASS2
8853 RMASS1 = RMASS2
8854 ELSE IF(IP.EQ.4) THEN
8855 XMASS1 = XMPOM
8856 RMASS1 = XMASS1
8857 ENDIF
8858 IF(IP.GT.1) THEN
8859 XMASS2 = XMPOM
8860 RMASS2 = XMASS2
8861 ENDIF
8862C update pomeron CM system
8863 PMASSP(1) = XMASS1
8864 PMASSP(2) = XMASS2
8865 ECMP = ECM
8866
8867 CZERO = DCMPLX(0.D0,0.D0)
8868 CONE = DCMPLX(1.D0,0.D0)
8869 ELAST = ECM
8870 PVOLD(1) = PVIRT(1)
8871 PVOLD(2) = PVIRT(2)
8872 IPOLD = IP
8873
8874C purely elastic scattering
8875 CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8876 ZXP(1,1) = ZIGP
8877 BXP(1,1) = BPOM
8878 ZXR(1,1) = ZIGR
8879 BXR(1,1) = BREG
8880 ZXH(1,1) = ZIGHR
8881 BXH(1,1) = BHAR
8882 ZXD(1,1) = ZIGHD
8883 BXD(1,1) = BHAD
8884 ZXT1A(1,1) = ZIGT1(1)
8885 BXT1A(1,1) = BTR1(1)
8886 ZXT1B(1,1) = ZIGT1(2)
8887 BXT1B(1,1) = BTR1(2)
8888 ZXT2A(1,1) = ZIGT2(1)
8889 BXT2A(1,1) = BTR2(1)
8890 ZXT2B(1,1) = ZIGT2(2)
8891 BXT2B(1,1) = BTR2(2)
8892 ZXL(1,1) = ZIGL
8893 BXL(1,1) = BLOO
8894 ZXDPE(1,1) = ZIGDP(1)
8895 BXDPE(1,1) = BDP(1)
8896 ZXDPA(1,1) = ZIGDP(2)
8897 BXDPA(1,1) = BDP(2)
8898 ZXDPB(1,1) = ZIGDP(3)
8899 BXDPB(1,1) = BDP(3)
8900 ZXDPD(1,1) = ZIGDP(4)
8901 BXDPD(1,1) = BDP(4)
8902 SBOPOM(1) = SIGP
8903 SBOREG(1) = SIGR
8904 SBOHAR(1) = SIGHR
8905 SBOHAD(1) = SIGHD
8906 SBOTR1(1,1) = SIGT1(1)
8907 SBOTR1(1,2) = SIGT1(2)
8908 SBOTR2(1,1) = SIGT2(1)
8909 SBOTR2(1,2) = SIGT2(2)
8910 SBOLPO(1) = SIGL
8911 SBODPO(1,1) = SIGDP(1)
8912 SBODPO(1,2) = SIGDP(2)
8913 SBODPO(1,3) = SIGDP(3)
8914 SBODPO(1,4) = SIGDP(4)
8915
8916C low mass single diffractive scattering 1
8917 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8918 ZXP(1,2) = ZIGP
8919 BXP(1,2) = BPOM
8920 ZXR(1,2) = ZIGR
8921 BXR(1,2) = BREG
8922 ZXH(1,2) = ZIGHR
8923 BXH(1,2) = BHAR
8924 ZXD(1,2) = ZIGHD
8925 BXD(1,2) = BHAD
8926 ZXT1A(1,2) = ZIGT1(1)
8927 BXT1A(1,2) = BTR1(1)
8928 ZXT1B(1,2) = ZIGT1(2)
8929 BXT1B(1,2) = BTR1(2)
8930 ZXT2A(1,2) = ZIGT2(1)
8931 BXT2A(1,2) = BTR2(1)
8932 ZXT2B(1,2) = ZIGT2(2)
8933 BXT2B(1,2) = BTR2(2)
8934 ZXL(1,2) = ZIGL
8935 BXL(1,2) = BLOO
8936 ZXDPE(1,2) = ZIGDP(1)
8937 BXDPE(1,2) = BDP(1)
8938 ZXDPA(1,2) = ZIGDP(2)
8939 BXDPA(1,2) = BDP(2)
8940 ZXDPB(1,2) = ZIGDP(3)
8941 BXDPB(1,2) = BDP(3)
8942 ZXDPD(1,2) = ZIGDP(4)
8943 BXDPD(1,2) = BDP(4)
8944 SBOPOM(2) = SIGP
8945 SBOREG(2) = SIGR
8946 SBOHAR(2) = SIGHR
8947 SBOHAD(2) = 0.D0
8948 SBOTR1(2,1) = SIGT1(1)
8949 SBOTR1(2,2) = SIGT1(2)
8950 SBOTR2(2,1) = SIGT2(1)
8951 SBOTR2(2,2) = SIGT2(2)
8952 SBOLPO(2) = SIGL
8953 SBODPO(2,1) = SIGDP(1)
8954 SBODPO(2,2) = SIGDP(2)
8955 SBODPO(2,3) = SIGDP(3)
8956 SBODPO(2,4) = SIGDP(4)
8957
8958C low mass single diffractive scattering 2
8959 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
8960 ZXP(1,3) = ZIGP
8961 BXP(1,3) = BPOM
8962 ZXR(1,3) = ZIGR
8963 BXR(1,3) = BREG
8964 ZXH(1,3) = ZIGHR
8965 BXH(1,3) = BHAR
8966 ZXD(1,3) = ZIGHD
8967 BXD(1,3) = BHAD
8968 ZXT1A(1,3) = ZIGT1(1)
8969 BXT1A(1,3) = BTR1(1)
8970 ZXT1B(1,3) = ZIGT1(2)
8971 BXT1B(1,3) = BTR1(2)
8972 ZXT2A(1,3) = ZIGT2(1)
8973 BXT2A(1,3) = BTR2(1)
8974 ZXT2B(1,3) = ZIGT2(2)
8975 BXT2B(1,3) = BTR2(2)
8976 ZXL(1,3) = ZIGL
8977 BXL(1,3) = BLOO
8978 ZXDPE(1,3) = ZIGDP(1)
8979 BXDPE(1,3) = BDP(1)
8980 ZXDPA(1,3) = ZIGDP(2)
8981 BXDPA(1,3) = BDP(2)
8982 ZXDPB(1,3) = ZIGDP(3)
8983 BXDPB(1,3) = BDP(3)
8984 ZXDPD(1,3) = ZIGDP(4)
8985 BXDPD(1,3) = BDP(4)
8986 SBOPOM(3) = SIGP
8987 SBOREG(3) = SIGR
8988 SBOHAR(3) = SIGHR
8989 SBOHAD(3) = 0.D0
8990 SBOTR1(3,1) = SIGT1(1)
8991 SBOTR1(3,2) = SIGT1(2)
8992 SBOTR2(3,1) = SIGT2(1)
8993 SBOTR2(3,2) = SIGT2(2)
8994 SBOLPO(3) = SIGL
8995 SBODPO(3,1) = SIGDP(1)
8996 SBODPO(3,2) = SIGDP(2)
8997 SBODPO(3,3) = SIGDP(3)
8998 SBODPO(3,4) = SIGDP(4)
8999
9000C low mass double diffractive scattering
9001 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9002 ZXP(1,4) = ZIGP
9003 BXP(1,4) = BPOM
9004 ZXR(1,4) = ZIGR
9005 BXR(1,4) = BREG
9006 ZXH(1,4) = ZIGHR
9007 BXH(1,4) = BHAR
9008 ZXD(1,4) = ZIGHD
9009 BXD(1,4) = BHAD
9010 ZXT1A(1,4) = ZIGT1(1)
9011 BXT1A(1,4) = BTR1(1)
9012 ZXT1B(1,4) = ZIGT1(2)
9013 BXT1B(1,4) = BTR1(2)
9014 ZXT2A(1,4) = ZIGT2(1)
9015 BXT2A(1,4) = BTR2(1)
9016 ZXT2B(1,4) = ZIGT2(2)
9017 BXT2B(1,4) = BTR2(2)
9018 ZXL(1,4) = ZIGL
9019 BXL(1,4) = BLOO
9020 ZXDPE(1,4) = ZIGDP(1)
9021 BXDPE(1,4) = BDP(1)
9022 ZXDPA(1,4) = ZIGDP(2)
9023 BXDPA(1,4) = BDP(2)
9024 ZXDPB(1,4) = ZIGDP(3)
9025 BXDPB(1,4) = BDP(3)
9026 ZXDPD(1,4) = ZIGDP(4)
9027 BXDPD(1,4) = BDP(4)
9028 SBOPOM(4) = SIGP
9029 SBOREG(4) = SIGR
9030 SBOHAR(4) = SIGHR
9031 SBOHAD(4) = 0.D0
9032 SBOTR1(4,1) = SIGT1(1)
9033 SBOTR1(4,2) = SIGT1(2)
9034 SBOTR2(4,1) = SIGT2(1)
9035 SBOTR2(4,2) = SIGT2(2)
9036 SBOLPO(4) = SIGL
9037 SBODPO(4,1) = SIGDP(1)
9038 SBODPO(4,2) = SIGDP(2)
9039 SBODPO(4,3) = SIGDP(3)
9040 SBODPO(4,4) = SIGDP(4)
9041
9042C calculate Born graph cross sections
9043 SBOPOM(0) = 0.D0
9044 SBOREG(0) = 0.D0
9045 SBOHAR(0) = 0.D0
9046 SBOHAD(0) = 0.D0
9047 SBOTR1(0,1) = 0.D0
9048 SBOTR1(0,2) = 0.D0
9049 SBOTR2(0,1) = 0.D0
9050 SBOTR2(0,2) = 0.D0
9051 SBOLPO(0) = 0.D0
9052 SBODPO(0,1) = 0.D0
9053 SBODPO(0,2) = 0.D0
9054 SBODPO(0,3) = 0.D0
9055 SBODPO(0,4) = 0.D0
9056 DO 150 I=1,4
9057 SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9058 SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9059 SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9060 SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9061 SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9062 SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9063 SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9064 SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9065 SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9066 SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9067 SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9068 SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9069 SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9070 150 CONTINUE
9071
9072 SIGPOM = SBOPOM(0)
9073 SIGREG = SBOREG(0)
9074 SIGTR1(1) = SBOTR1(0,1)
9075 SIGTR1(2) = SBOTR1(0,2)
9076 SIGTR2(1) = SBOTR2(0,1)
9077 SIGTR2(2) = SBOTR2(0,2)
9078 SIGLOO = SBOLPO(0)
9079 SIGDPO(1) = SBODPO(0,1)
9080 SIGDPO(2) = SBODPO(0,2)
9081 SIGDPO(3) = SBODPO(0,3)
9082 SIGDPO(4) = SBODPO(0,4)
9083 SIGHAR = SBOHAR(0)
9084 SIGDIR = SBOHAD(0)
9085 ENDIF
9086
9087 B24=DCMPLX(B**2,0.D0)/4.D0
9088
9089 AMPEL = CZERO
9090 AMPR = CZERO
9091 AMPO = CZERO
9092 AMPP = CZERO
9093 AMPQ = CZERO
9094 AMLMSD(1) = CZERO
9095 AMLMSD(2) = CZERO
9096 AMHMSD(1) = CZERO
9097 AMHMSD(2) = CZERO
9098 AMLMDD = CZERO
9099 AMHMDD = CZERO
9100
9101C different models
9102
9103 IF(ISWMDL(1).LT.3) THEN
9104C pomeron
9105 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9106C reggeon
9107 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9108C hard resolved processes
9109 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9110C hard direct processes
9111 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9112C triple-Pomeron: baryon high mass diffraction
9113 AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9114 & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9115C triple-Pomeron: photon/meson high mass diffraction
9116 AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9117 & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9118C loop-Pomeron
9119 AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
9120 ENDIF
9121
9122 IF(ISWMDL(1).EQ.0) THEN
9123 AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9124 & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9125 & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9126 & )
9127 AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9128 & +AUXT1+AUXT2+AUXL))
9129 AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9130 & +AUXT1+AUXT2+AUXL))
9131 AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9132 & +AUXT1+AUXT2+AUXL))
9133 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9134 & +AUXT1+AUXT2+AUXL))
9135
9136 ELSE IF(ISWMDL(1).EQ.1) THEN
9137 AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9138 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9139 AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9140 & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9141 AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9142 & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9143 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9144 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9145 AMPEL = SQRT(VDMQ2F(1))*AMPR
9146 & + SQRT(VDMQ2F(2))*AMPO
9147 & + SQRT(VDMQ2F(3))*AMPP
9148 & + SQRT(VDMQ2F(4))*AMPQ
9149 & + AUXD/2.D0
9150
9151C simple analytic two channel model (version A)
9152 ELSE IF(ISWMDL(1).EQ.3) THEN
9153 CALL PHO_CHAN2A(B)
9154
9155 ELSE
9156 WRITE(LO,'(1X,A,I2)')
9157 & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9158 STOP
9159 ENDIF
9160
9161 END
9162
9163*$ CREATE PHO_DSIGDT.FOR
9164*COPY PHO_DSIGDT
9165CDECK ID>, PHO_DSIGDT
9166 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9167C*********************************************************************
9168C
9169C calculation of unitarized amplitude
9170C and differential cross section
9171C
9172C input: EE cm energy (GeV)
9173C XTA(1,*) t values (GeV**2)
9174C NFILL entries in t table
9175C
9176C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9177C XTA(3,*) DSIG/DT g p --> rho0 h/V
9178C XTA(4,*) DSIG/DT g p --> omega0 h/V
9179C XTA(5,*) DSIG/DT g p --> phi h/V
9180C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9181C
9182C*********************************************************************
9183 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9184 SAVE
9185
9186 PARAMETER(ITWO=2,
9187 & ITHREE=3,
9188 & THOUS=1.D3,
9189 & DEPS=1.D-20)
9190
9191 DIMENSION XTA(6,NFILL)
9192
9193C input/output channels
9194 INTEGER LI,LO
9195 COMMON /POINOU/ LI,LO
9196C some constants
9197 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9198 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9199 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9200C integration precision for hard cross sections (obsolete)
9201 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9202 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9203C event debugging information
9204 INTEGER NMAXD
9205 PARAMETER (NMAXD=100)
9206 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9207 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9208 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9209 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9210C global event kinematics and particle IDs
9211 INTEGER IFPAP,IFPAB
9212 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9213 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9214C complex Born graph amplitudes used for unitarization
9215 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9216 & AMHMDD,AMPDP
9217 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9218 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9219
9220 COMPLEX*16 XT,AMP,CZERO
9221 DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
9222 CHARACTER*12 FNA
9223
9224 CDABS(AMPEL) = ABS(AMPEL)
9225 DCMPLX(X,Y) = CMPLX(X,Y)
9226
9227 CZERO=DCMPLX(0.D0,0.D0)
9228
9229 ETMP = ECM
9230 ECM = EE
9231
9232 IF(NFILL.GT.100) THEN
9233 WRITE(LO,'(1X,A,I4)')
9234 & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9235 STOP
9236 ENDIF
9237C
9238 DO 100 K=1,NFILL
9239 DO 150 L=1,5
9240 XT(L,K)=CZERO
9241 150 CONTINUE
9242 100 CONTINUE
9243C
9244C impact parameter integration
9245C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9246 BMAX=10.D0
9247 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9248 IAMP = 5
9249 IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9250 I1 = 1
9251 I2 = 0
9252 ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9253 I1 = 0
9254 I2 = 1
9255 ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9256 I1 = 1
9257 I2 = 1
9258 ELSE
9259 I1 = 0
9260 I2 = 0
9261 IAMP = 1
9262 ENDIF
9263 J1 = I1*2
9264 K1 = I1*3
9265 L1 = I1*4
9266 J2 = I2*2
9267 K2 = I2*3
9268 L2 = I2*4
9269C
9270 DO 200 I=1,NGAUSO
9271 WG=WGHT(I)*XPNT(I)
9272C calculate amplitudes
9273 IF(I.EQ.1) THEN
9274 CALL PHO_EIKON(1,-1,XPNT(I))
9275 ELSE
9276 CALL PHO_EIKON(1,1,XPNT(I))
9277 ENDIF
9278 AMP(1) = AMPEL
9279 AMP(2) = AMPVM(I1,I2)
9280 AMP(3) = AMPVM(J1,J2)
9281 AMP(4) = AMPVM(K1,K2)
9282 AMP(5) = AMPVM(L1,L2)
9283C
9284 DO 400 J=1,NFILL
9285 XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9286 FAC = PHO_BESSJ0(XX)*WG
9287 DO 500 K=1,IAMP
9288 XT(1,J)=XT(1,J)+AMP(K)*FAC
9289 500 CONTINUE
9290 400 CONTINUE
9291 200 CONTINUE
9292C
9293C change units to mb/GeV**2
9294 FAC = 4.D0*PI/GEV2MB
9295 FNA = '(mb/GeV**2) '
9296 IF(I1+I2.EQ.1) THEN
9297 FAC = FAC*THOUS
9298 FNA = '(mub/GeV**2)'
9299 ELSE IF(I1+I2.EQ.2) THEN
9300 FAC = FAC*THOUS*THOUS
9301 FNA = '(nb/GeV**2) '
9302 ENDIF
9303 IF(IDEB(56).GE.5) THEN
9304 WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
9305 & FNA,'------------------------------------------'
9306 ENDIF
9307 DO 600 J=1,NFILL
9308 DO 700 K=1,IAMP
9309 XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9310 700 CONTINUE
9311 IF(IDEB(56).GE.5) THEN
9312 WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9313 ENDIF
9314 600 CONTINUE
9315
9316 ECM = ETMP
9317 END
9318
9319*$ CREATE PHO_XSECT.FOR
9320*COPY PHO_XSECT
9321CDECK ID>, PHO_XSECT
9322 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9323C*********************************************************************
9324C
9325C calculation of physical cross sections
9326C
9327C input: IP particle combination
9328C IFHARD -1 reset Born graph cross section tables
9329C 0 calculate hard cross sections or take them
9330C from interpolation table (if available)
9331C 1 assume that hard cross sections are already
9332C calculated and stored in /POSBRN/
9333C EE cms energy (GeV)
9334C
9335C output: /POSBRN/ input cross sections
9336C /POZBRN/ scaled input cross values
9337C /POCSEC/ physical cross sections and slopes
9338C
9339C slopes in GeV**-2, cross sections in mb
9340C
9341C*********************************************************************
9342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9343 SAVE
9344
9345 PARAMETER(ONEM=-1.D0,
9346 & THOUS=1.D3,
9347 & DEPS=1.D-20)
9348
9349C input/output channels
9350 INTEGER LI,LO
9351 COMMON /POINOU/ LI,LO
9352C some constants
9353 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9354 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9355 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9356C event debugging information
9357 INTEGER NMAXD
9358 PARAMETER (NMAXD=100)
9359 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9360 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9361 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9362 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9363C integration precision for hard cross sections (obsolete)
9364 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9365 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9366C model switches and parameters
9367 CHARACTER*8 MDLNA
9368 INTEGER ISWMDL,IPAMDL
9369 DOUBLE PRECISION PARMDL
9370 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9371C Born graph cross sections and slopes
9372 INTEGER Max_pro_3
9373 PARAMETER ( Max_pro_3 = 16 )
9374 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9375 & SIGD1,SIGD2,DSIGH
9376 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9377 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9378C cross sections
9379 INTEGER IPFIL,IFAFIL,IFBFIL
9380 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9381 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9382 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9383 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9384 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9385 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9386 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9387 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9388 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9389 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9390 & IPFIL,IFAFIL,IFBFIL
9391C global event kinematics and particle IDs
9392 INTEGER IFPAP,IFPAB
9393 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9394 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9395
9396 CHARACTER*15 PHO_PNAME
9397
9398C complex Born graph amplitudes used for unitarization
9399 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9400 & AMHMDD,AMPDP
9401 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9402 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9403
9404 DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9405 CHARACTER*8 VMESA(0:4),VMESB(0:4)
9406 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
9407 & 'pi+pi- ' /
9408 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
9409 & 'pi+pi- ' /
9410
9411 CDABS(AMPEL) = ABS(AMPEL)
9412
9413 ETMP = ECM
9414 IF(EE.LT.0.D0) GOTO 500
9415 ECM = EE
9416
9417C impact parameter integration
9418C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9419 BMAX=10.D0
9420 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9421 SIGTOT = 0.D0
9422 SIGINE = 0.D0
9423 SIGELA = 0.D0
9424 SIGNDF = 0.D0
9425 SIGLSD(1) = 0.D0
9426 SIGLSD(2) = 0.D0
9427 SIGLDD = 0.D0
9428 SIGHSD(1) = 0.D0
9429 SIGHSD(2) = 0.D0
9430 SIGHDD = 0.D0
9431 SIGCDF(0) = 0.D0
9432 SIG1SO = 0.D0
9433 SIG1HA = 0.D0
9434 SLEL1 = 0.D0
9435 SLEL2 = 0.D0
9436 DO 50 I=1,4
9437 SIGCDF(I) = 0.D0
9438 DO 55 K=1,4
9439 SIGVM(I,K) = 0.D0
9440 SLVM1(I,K) = 0.D0
9441 SLVM2(I,K) = 0.D0
9442 55 CONTINUE
9443 50 CONTINUE
9444
9445 DO 100 I=1,NGAUSO
9446 B2 = XPNT(I)**2
9447 WG = WGHT(I)*XPNT(I)
9448 WGB = B2*WG
9449
9450C calculate impact parameter amplitude, results in /POINT4/
9451 IF(I.EQ.1) THEN
9452 CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9453 ELSE
9454 CALL PHO_EIKON(IP,1,XPNT(I))
9455 ENDIF
9456
9457 SIGTOT = SIGTOT + DREAL(AMPEL)*WG
9458 SIGELA = SIGELA + CDABS(AMPEL)**2*WG
9459 SLEL1 = SLEL1 + AMPEL*WGB
9460 SLEL2 = SLEL2 + AMPEL*WG
9461
9462 DO 110 J=1,4
9463 DO 120 K=1,4
9464 SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9465 SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9466 SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9467 120 CONTINUE
9468 SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
9469 110 CONTINUE
9470
9471 SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9472 SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9473 SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
9474 SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
9475 SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
9476 SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9477 SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9478 SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
9479
9480 100 CONTINUE
9481
9482 SIGDIR = DREAL(SIGHD)
9483 FAC = 4.D0*PI2
9484 SIGTOT = SIGTOT*FAC
9485 SIGELA = SIGELA*FAC
9486 FACSL = 0.5D0/GEV2MB
9487 SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
9488
9489 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9490 DO 130 I=1,4
9491 DO 140 J=1,4
9492 SIGVM(I,J) = SIGVM(I,J)*FAC
9493 SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9494 140 CONTINUE
9495 130 CONTINUE
9496 SIGVM(0,0) = 0.D0
9497 DO 150 I=1,4
9498 SIGVM(0,I) = 0.D0
9499 SIGVM(I,0) = 0.D0
9500 DO 160 J=1,4
9501 SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9502 SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9503 160 CONTINUE
9504 SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9505 150 CONTINUE
9506 ENDIF
9507
9508C diffractive cross sections
9509
9510 SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9511 SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9512 SIGLDD = SIGLDD *FAC*PARMDL(42)
9513 SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9514 SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9515 SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9516 & *FAC*PARMDL(42)
9517
9518C double pomeron scattering
9519
9520 SIGCDF(0) = 0.D0
9521 DO 170 I=1,4
9522 SIGCDF(I) = SIGCDF(I)*FAC
9523 SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9524 170 CONTINUE
9525
9526 SIG1SO = SIG1SO *FAC
9527 SIG1HA = SIG1HA *FAC
9528
9529 SIGINE = SIGTOT - SIGELA
9530
9531C user-forced change of diffractive cross section
9532
9533 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9534
9535C use optional explicit parametrization for single-diffraction
9536
9537 SIGSD1 = SIGLSD(1)+SIGHSD(1)
9538 SIGSD2 = SIGLSD(2)+SIGHSD(2)
9539 SS = EE*EE
9540 XI_MIN = 1.5D0/SS
9541 XI_MAX = PARMDL(45)**2
9542 CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9543 & SIG_SD1,SIG_SD2,SIG_DD)
9544 SIG_SD1 = SIG_SD1*PARMDL(40)
9545 SIG_SD2 = SIG_SD2*PARMDL(41)
9546**sr
9547C DEL_SD1 = SIG_SD1-SIGSD1
9548 DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9549**
9550 FAC = SIGLSD(1)/SIGSD1
9551 SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9552 SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9553C DEL_SD2 = SIG_SD2-SIGSD2
9554 DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9555 FAC = SIGLSD(2)/SIGSD2
9556 SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9557 SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9558
9559 IF(ISWMDL(30).GE.2) THEN
9560
9561C use explicit parametrization also for double diffraction diss.
9562 SIGDD = SIGLDD+SIGHDD
9563 SIG_DD = SIG_DD*PARMDL(42)
9564 DEL_DD = SIG_DD-SIGDD
9565 FAC = SIGLDD/SIGDD
9566 SIGLDD = SIGLDD+FAC*DEL_DD
9567 SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9568 SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9569
9570 ELSE
9571
9572C rescale double diffraction cross sections
9573 SIGLDD = SIGLDD *PARMDL(42)
9574 SIGHDD = SIGHDD *PARMDL(42)
9575 SIGCOR = DEL_SD1 + DEL_SD2
9576 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9577
9578 ENDIF
9579
9580 ELSE
9581
9582C rescale unitarized cross sections for diffraction dissociation
9583
9584 SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9585 SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9586 SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9587 SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9588 SIGLDD = SIGLDD *PARMDL(42)
9589 SIGHDD = SIGHDD *PARMDL(42)
9590 SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9591 & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9592 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9593
9594 ENDIF
9595
9596C non-diffractive inelastic cross section
9597
9598 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9599 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9600 & -SIGLDD-SIGHDD
9601
9602C specify elastic scattering channel
9603
9604 500 CONTINUE
9605 IF(IFPAP(1).NE.22) THEN
9606 VMESA(1) = PHO_PNAME(IFPAB(1),0)
9607 ELSE
9608 VMESA(1) = 'rho '
9609 ENDIF
9610 IF(IFPAP(2).NE.22) THEN
9611 VMESB(1) = PHO_PNAME(IFPAB(2),0)
9612 ELSE
9613 VMESB(1) = 'rho '
9614 ENDIF
9615
9616C write out physical cross sections
9617
9618 IF(IDEB(57).GE.5) THEN
9619 WRITE(LO,'(/1X,A,I3,/1X,A)')
9620 & 'PHO_XSECT: cross sections (mb) for combination',IP,
9621 & '----------------------------------------------'
9622 WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9623 WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
9624 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
9625 WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
9626 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9627 & SIGLSD(1)+SIGHSD(1)
9628 IF(IDEB(57).GE.7) THEN
9629 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
9630 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
9631 ENDIF
9632 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9633 & SIGLSD(2)+SIGHSD(2)
9634 IF(IDEB(57).GE.7) THEN
9635 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
9636 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
9637 ENDIF
9638 WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
9639 IF(IDEB(57).GE.7) THEN
9640 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
9641 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
9642 ENDIF
9643 WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
9644 IF(IDEB(57).GE.7) THEN
9645 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
9646 WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9647 WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9648 WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
9649 ENDIF
9650 WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
9651 DO 200 I=1,4
9652 DO 210 J=1,4
9653 IF(SIGVM(I,J).GT.DEPS) THEN
9654 WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9655 & VMESA(I),VMESB(J)
9656 WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9657 IF((I.NE.0).AND.(J.NE.0))
9658 & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9659 ENDIF
9660 210 CONTINUE
9661 200 CONTINUE
9662 IF(IDEB(57).GE.7) THEN
9663 WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9664 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
9665 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
9666 WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
9667 WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
9668 WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9669 WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
9670 & DREAL(DSIGH(15))
9671 ENDIF
9672 ENDIF
9673
9674 ECM = ETMP
9675
9676 END
9677
9678*$ CREATE PHO_IMPAMP.FOR
9679*COPY PHO_IMPAMP
9680CDECK ID>, PHO_IMPAMP
9681 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9682C*********************************************************************
9683C
9684C calculation of physical impact parameter amplitude
9685C
9686C input: EE cm energy (GeV)
9687C BMIN lower bound in B
9688C BMAX upper bound in B
9689C NSTEP number of values (linear)
9690C
9691C output: values written to output unit
9692C
9693C*********************************************************************
9694 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9695 SAVE
9696
9697 PARAMETER(ONEM=-1.D0,
9698 & THOUS=1.D3,
9699 & DEPS=1.D-20)
9700
9701C input/output channels
9702 INTEGER LI,LO
9703 COMMON /POINOU/ LI,LO
9704C event debugging information
9705 INTEGER NMAXD
9706 PARAMETER (NMAXD=100)
9707 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9708 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9709 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9710 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9711C model switches and parameters
9712 CHARACTER*8 MDLNA
9713 INTEGER ISWMDL,IPAMDL
9714 DOUBLE PRECISION PARMDL
9715 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9716C global event kinematics and particle IDs
9717 INTEGER IFPAP,IFPAB
9718 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9719 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9720C complex Born graph amplitudes used for unitarization
9721 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9722 & AMHMDD,AMPDP
9723 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9724 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9725
9726 ECM=EE
9727 BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9728C
9729 WRITE(LO,'(3(/,1X,A))')
9730 & 'impact parameter amplitudes:',
9731 & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
9732 & '-------------------------------------------------------------'
9733C
9734 BB = BMIN
9735 DO 100 I=1,NSTEP
9736C calculate impact parameter amplitudes
9737 IF(I.EQ.1) THEN
9738 CALL PHO_EIKON(1,-1,BMIN)
9739 ELSE
9740 CALL PHO_EIKON(1,1,BB)
9741 ENDIF
9742 WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9743 & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9744 & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9745 BB = BB+BSTEP
9746 100 CONTINUE
9747
9748 END
9749
9750*$ CREATE PHO_PRBDIS.FOR
9751*COPY PHO_PRBDIS
9752CDECK ID>, PHO_PRBDIS
9753 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9754C*********************************************************************
9755C
9756C calculation of multi interactions probabilities
9757C
9758C input: IP particle combination to scatter
9759C ECM CMS energy
9760C IE index for weight storing
9761C /PROBAB/
9762C IMAX max. number of soft pomeron interactions
9763C KMAX max. number of hard pomeron interactions
9764C
9765C output: /PROBAB/
9766C PROB field of probabilities
9767C
9768C*********************************************************************
9769 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9770 SAVE
9771
9772 PARAMETER ( EPS=1.D-10 )
9773
9774C input/output channels
9775 INTEGER LI,LO
9776 COMMON /POINOU/ LI,LO
9777C event debugging information
9778 INTEGER NMAXD
9779 PARAMETER (NMAXD=100)
9780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9784C Reggeon phenomenology parameters
9785 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9786 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9787 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9788 & ALREG,ALREGP,GR(2),B0REG(2),
9789 & GPPP,GPPR,B0PPP,B0PPR,
9790 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9791C parameters of 2x2 channel model
9792 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9793 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9794C Born graph cross sections and slopes
9795 INTEGER Max_pro_3
9796 PARAMETER ( Max_pro_3 = 16 )
9797 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9798 & SIGD1,SIGD2,DSIGH
9799 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9800 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9801C obsolete cut-off information
9802 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9803 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9804C Born graph cross sections after applying diffraction model
9805 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9806 & SBOLPO,SBODPO
9807 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9808 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9809 & SBODPO(0:4,4)
9810C cross sections
9811 INTEGER IPFIL,IFAFIL,IFBFIL
9812 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9813 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9814 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9815 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9816 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9817 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9818 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9819 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9820 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9821 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9822 & IPFIL,IFAFIL,IFBFIL
9823C cut probability distribution
9824 INTEGER IEETA1,IIMAX,KKMAX
9825 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9826 INTEGER IEEMAX,IMAX,KMAX
9827 REAL PROB
9828 DOUBLE PRECISION EPTAB
9829 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9830 & IEEMAX,IMAX,KMAX
9831C energy-interpolation table
9832 INTEGER IEETA2
9833 PARAMETER ( IEETA2 = 20 )
9834 INTEGER ISIMAX
9835 DOUBLE PRECISION SIGTAB,SIGECM
9836 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9837C average number of cut soft and hard ladders (obsolete)
9838 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9839 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9840C some constants
9841 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9842 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9843 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9844C integration precision for hard cross sections (obsolete)
9845 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9846 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9847C model switches and parameters
9848 CHARACTER*8 MDLNA
9849 INTEGER ISWMDL,IPAMDL
9850 DOUBLE PRECISION PARMDL
9851 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9852C unitarized amplitudes for different diffraction channels
9853 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9854 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9855 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9856 & ZXL,BXL
9857 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9858 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9859 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9860 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9861 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9862 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9863 & ZXL(4,4),BXL(4,4)
9864
9865C local variables
9866 DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9867 PARAMETER (ICHMAX=40)
9868 DIMENSION CHIFAC(4,4),AMPCOF(4)
9869 DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9870 DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9871
9872C combinatorical factors
9873 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9874 & 1.D0,-1.D0, 1.D0,-1.D0,
9875 & 1.D0,-1.D0,-1.D0, 1.D0,
9876 & 1.D0, 1.D0, 1.D0, 1.D0 /
9877
9878 DATA FACLOG / .000000000000000D+00,
9879 & .000000000000000D+00, .693147180559945D+00,
9880 & .109861228866811D+01, .138629436111989D+01,
9881 & .160943791243410D+01, .179175946922805D+01,
9882 & .194591014905531D+01, .207944154167984D+01,
9883 & .219722457733622D+01, .230258509299405D+01,
9884 & .239789527279837D+01, .248490664978800D+01,
9885 & .256494935746154D+01, .263905732961526D+01,
9886 & .270805020110221D+01, .277258872223978D+01,
9887 & .283321334405622D+01, .289037175789616D+01,
9888 & .294443897916644D+01, .299573227355399D+01,
9889 & .304452243772342D+01, .309104245335832D+01,
9890 & .313549421592915D+01, .317805383034795D+01,
9891 & .321887582486820D+01, .325809653802148D+01,
9892 & .329583686600433D+01, .333220451017520D+01,
9893 & .336729582998647D+01, .340119738166216D+01 /
9894
9895 DATA ELAST / 0.D0 /
9896 DATA IPLAST / 0 /
9897
9898C test for redundant calculation: skip cs calculation
9899 IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9900 ELAST = ECM
9901 IPLAST = IP
9902 CALL PHO_XSECT(IP,0,ELAST)
9903 ISIMAX = IE
9904 SIGECM(IP,IE) = ECM
9905 SIGTAB(IP,1,IE) = SIGTOT
9906 SIGTAB(IP,2,IE) = SIGELA
9907 J = 2
9908 DO 5 I=0,4
9909 DO 6 K=0,4
9910 J = J+1
9911 SIGTAB(IP,J,IE) = SIGVM(I,K)
9912 6 CONTINUE
9913 5 CONTINUE
9914 SIGTAB(IP,28,IE) = SIGINE
9915 SIGTAB(IP,29,IE) = SIGDIR
9916 SIGTAB(IP,30,IE) = SIGLSD(1)
9917 SIGTAB(IP,31,IE) = SIGLSD(2)
9918 SIGTAB(IP,32,IE) = SIGHSD(1)
9919 SIGTAB(IP,33,IE) = SIGHSD(2)
9920 SIGTAB(IP,34,IE) = SIGLDD
9921 SIGTAB(IP,35,IE) = SIGHDD
9922 SIGTAB(IP,36,IE) = SIGCDF(0)
9923 SIGTAB(IP,37,IE) = SIG1SO
9924 SIGTAB(IP,38,IE) = SIG1HA
9925 SIGTAB(IP,39,IE) = SLOEL
9926 J = 39
9927 DO 7 I=1,4
9928 DO 8 K=1,4
9929 J = J+1
9930 SIGTAB(IP,J,IE) = SLOVM(I,K)
9931 8 CONTINUE
9932 7 CONTINUE
9933 SIGTAB(IP,56,IE) = SIGPOM
9934 SIGTAB(IP,57,IE) = SIGREG
9935 SIGTAB(IP,58,IE) = SIGHAR
9936 SIGTAB(IP,59,IE) = SIGDIR
9937 SIGTAB(IP,60,IE) = SIGTR1(1)
9938 SIGTAB(IP,61,IE) = SIGTR1(2)
9939 SIGTAB(IP,62,IE) = SIGTR2(1)
9940 SIGTAB(IP,63,IE) = SIGTR2(2)
9941 SIGTAB(IP,64,IE) = SIGLOO
9942 SIGTAB(IP,65,IE) = SIGDPO(1)
9943 SIGTAB(IP,66,IE) = SIGDPO(2)
9944 SIGTAB(IP,67,IE) = SIGDPO(3)
9945 SIGTAB(IP,68,IE) = SIGDPO(4)
9946
9947C consistency check
9948 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9949 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9950 & -SIGLDD-SIGHDD
9951
9952 IF(SIGNDF.LE.0.D0) THEN
9953 WRITE(LO,'(//1X,A,/)')
9954 & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
9955 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
9956 & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
9957 WRITE(LO,'(4X,A,/1P,8E10.3)')
9958 &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
9959 & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
9960 & SIGLSD(2),SIGLDD
9961 STOP
9962 ENDIF
9963
9964 IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
ecf67adb 9965 WRITE(LO,*) '------------------------------------------------'
9966 WRITE(LO,*) 'IP,ECM:',IP,ECM
9967 WRITE(LO,*) 'SIGTOT:',SIGTOT
9968 WRITE(LO,*) 'SIGELA:',SIGELA
9969 WRITE(LO,*) 'SIGVM :',SIGVM(0,0)
9970 WRITE(LO,*) 'SIGCDF:',SIGCDF(0)
9971 WRITE(LO,*) 'SIGDIR:',SIGDIR
9972 WRITE(LO,*) 'SIGLSD:',SIGLSD
9973 WRITE(LO,*) 'SIGHSD:',SIGHSD
9974 WRITE(LO,*) 'SIGLDD:',SIGLDD
9975 WRITE(LO,*) 'SIGHDD:',SIGHDD
9976 WRITE(LO,*) 'SIGNDF:',SIGNDF
9977
9978 WRITE(LO,*) 'SIGPOM:',SIGPOM
9979 WRITE(LO,*) 'SIGREG:',SIGREG
9980 WRITE(LO,*) 'SIGHAR:',SIGHAR
9981 WRITE(LO,*) 'SIGDIR:',SIGDIR
9982 WRITE(LO,*) 'SIGTR1:',SIGTR1
9983 WRITE(LO,*) 'SIGTR2:',SIGTR2
9984 WRITE(LO,*) 'SIGLOO:',SIGLOO
9985 WRITE(LO,*) 'SIGDPO:',SIGDPO
9986 WRITE(LO,*) 'SIG1SO:',SIG1SO
9987 WRITE(LO,*) 'SIG1HA:',SIG1HA
9aaba0d6 9988 ENDIF
9989
9990 SIGTAB(IP,77,IE) = PTCUT(IP)
9991 SIGTAB(IP,78,IE) = SIGNDF
9992
9993 AUXFAC = PI2/SIGNDF
9994 IF(ISWMDL(1).EQ.3) THEN
9995 DO 133 I=1,4
9996 AMPCOF(I) = 0.D0
9997 DO 135 K=1,4
9998 AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
9999 135 CONTINUE
10000 AMPCOF(I) = AMPCOF(I)*AUXFAC
10001 133 CONTINUE
10002 ENDIF
10003C
10004* BMAX=5.D0*SQRT(DBLE(BPOM))
10005 BMAX=10.D0
10006 EPTAB(IP,IE) = ECM
10007 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10008C
10009 ENDIF
10010C
10011 DO 160 K=0,KMAX
10012 DO 170 I=0,IMAX
10013 PROB(IP,IE,I,K) = 0.D0
10014 170 CONTINUE
10015 160 CONTINUE
10016 DO 120 I=1,ICHMAX
10017 PCHAIN(1,I) = 0.D0
10018 PCHAIN(2,I) = 0.D0
10019 120 CONTINUE
10020C
10021C main cross section loop
10022C**********************************************************
10023 DO 5000 IB=1,NGAUSO
10024 B24=XPNT(IB)**2/4.D0
10025 FAC = XPNT(IB)*WGHT(IB)
10026C
10027 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10028C
10029C amplitude construction
10030 DO 525 I=1,4
10031 AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10032 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
10033 AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10034 AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10035 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10036 & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10037 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10038 & -ZXL(1,I)*EXP(-B24/BXL(1,I))
10039 AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10040 & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10041 & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10042 & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10043 AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10044 AB(2,I) = AB(2,I)
10045 AB(3,I) = 0.D0
10046 AB(4,I) = 0.D0
10047*
10048 525 CONTINUE
10049C
10050 DO 460 I=1,4
10051 DO 500 K=1,4
10052 ABSUM2(I,K) = 0.D0
10053 DO 550 L=1,4
10054 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10055 550 CONTINUE
10056 ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10057 500 CONTINUE
10058 460 CONTINUE
10059 DO 600 I=1,4
10060 CHI2(I) = 0.D0
10061 DO 650 K=1,4
10062 CHI2(I) = CHI2(I) + ABSUM2(K,I)
10063 650 CONTINUE
10064 600 CONTINUE
10065C sums instead of products
10066 DO 660 I=1,4
10067 DO 670 KD=1,4
10068 DTMP = ABS(ABSUM2(I,KD))
10069 IF(DTMP.LT.1.D-30) THEN
10070 ABSUM2(I,KD) = -50.D0
10071 ELSE
10072 ABSUM2(I,KD) = LOG(DTMP)
10073 ENDIF
10074 670 CONTINUE
10075 660 CONTINUE
10076
10077 IF(MAX(IMAX,KMAX).GT.30) THEN
10078 WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10079 & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10080 CALL PHO_ABORT
10081 ENDIF
10082 DO 700 KD=1,4
10083 DO 750 I=1,4
10084 ABSTMP(I) = ABSUM2(I,KD)
10085 750 CONTINUE
10086C recursive sum
10087 CHITMP(1) = -ABSUM2(1,KD)
10088 DO 800 I=0,IMAX
10089 CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10090 CHITMP(2) = -ABSTMP(2)
10091 DO 810 K=0,KMAX
10092 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10093C calculation of elastic part
10094 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10095 IF(DTMP.LT.-30.D0) THEN
10096 DTMP = 0.D0
10097 ELSE
10098 DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10099 ENDIF
10100 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10101 810 CONTINUE
10102 800 CONTINUE
10103 700 CONTINUE
10104 PROB(IP,IE,0,0) = 0.D0
10105C
10106C**********************************************************
10107 ELSE
10108 WRITE(LO,'(1X,A,I3)')
10109 & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10110 STOP
10111 ENDIF
10112 5000 CONTINUE
10113
10114C debug output
10115 IF(IDEB(55).GE.15) THEN
10116 WRITE(LO,'(/,1X,A,I3,E11.4)')
10117 & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10118 & IP,ECM
10119 DO 905 I=0,MIN(IMAX,5)
10120 DO 915 K=0,MIN(KMAX,5)
10121 IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10122 & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10123 915 CONTINUE
10124 905 CONTINUE
10125 ENDIF
10126C string probability (uncorrected)
10127 IF(IDEB(55).GE.5) THEN
10128 DO 955 I=0,IMAX
10129 DO 965 K=0,KMAX
10130 INDX = 2*I+2*K
10131 IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10132 PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10133 ENDIF
10134 965 CONTINUE
10135 955 CONTINUE
10136 WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10137 & 'list of selected probabilities (uncorr,ECM)',ECM
10138 WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
10139 DO 183 I=0,IIMAX
10140 IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10141 & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10142 & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10143 183 CONTINUE
10144 ENDIF
10145C substract high-mass single and double diffraction
10146 PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10147 & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10148 PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10149C
10150C probability check
10151 CHKSUM = 0.D0
10152 PRONEG = 0.D0
10153 AVERI = 0.D0
10154 AVERK = 0.D0
10155 AVERL = 0.D0
10156 AVERM = 0.D0
10157 AVERN = 0.D0
10158 SIGMI = 0.D0
10159 SIGMK = 0.D0
10160 SIGML = 0.D0
10161 SIGMM = 0.D0
10162 DO 1001 I=0,IMAX
10163 PSOFT(I) = 0.D0
10164 1001 CONTINUE
10165 DO 1002 K=0,KMAX
10166 PHARD(K) = 0.D0
10167 1002 CONTINUE
10168 DO 1000 K=0,KMAX
10169 DO 1010 I=0,IMAX
10170 TMP = PROB(IP,IE,I,K)
10171 IF(TMP.LT.0.D0) THEN
10172 IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10173 WRITE(LO,'(1X,A,4I4,E14.4)')
10174 & 'PHO_PRBDIS: neg.probability:',
10175 & IP,IE,I,K,PROB(IP,IE,I,K)
10176 ENDIF
10177 PRONEG = PRONEG+TMP
10178 TMP = 0.D0
10179 ENDIF
10180 CHKSUM = CHKSUM+TMP
10181 AVERI = AVERI+DBLE(I)*TMP
10182 AVERK = AVERK+DBLE(K)*TMP
10183 SIGMI = SIGMI+DBLE(I**2)*TMP
10184 SIGMK = SIGMK+DBLE(K**2)*TMP
10185 PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10186 PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10187 PROB(IP,IE,I,K) = CHKSUM
10188 1010 CONTINUE
10189 1000 CONTINUE
10190C
10191 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10192 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10193C cut probabilites output
10194 IF(IDEB(55).GE.5) THEN
10195 WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10196 DO 185 I=1,ICHMAX
10197 IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10198 & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10199 185 CONTINUE
10200 ENDIF
10201C rescaling necessary
10202 IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10203 FAC = 1.D0/CHKSUM
10204 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10205 & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10206 DO 40 K=0,KMAX
10207 DO 50 I=0,IMAX
10208 PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10209 50 CONTINUE
10210 40 CONTINUE
10211 AVERI = AVERI*FAC
10212 AVERK = AVERK*FAC
10213 AVERL = AVERL*FAC
10214 AVERM = AVERM*FAC
10215 SIGMI = SIGMI*FAC**2
10216 SIGMK = SIGMK*FAC**2
10217 SIGML = SIGML*FAC**2
10218 SIGMM = SIGMM*FAC**2
10219 ENDIF
10220C
10221C probability to find Reggeon/Pomeron
10222 PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10223 AVERJ = -PROB(IP,IE,0,0)*AVERI
10224 AVERII = AVERI-AVERJ
10225C
10226 SIGTAB(IP,74,IE) = AVERII
10227 SIGTAB(IP,75,IE) = AVERK
10228 SIGTAB(IP,76,IE) = AVERJ
10229C
10230 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10231 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10232C
10233 IF(IDEB(55).GE.1) THEN
10234
10235C average interaction probabilities
10236 WRITE(LO,'(/1X,A,/1X,A)')
10237 & 'PHO_PRBDIS: expected interaction statistics',
10238 & '-------------------------------------------'
10239 WRITE(LO,'(1X,A,E12.4,2I3)')
10240 & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10241 WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10242 & IMAX,KMAX
10243 WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10244 & 'averaged number of cuts per event (eff. cs):',SIGNDF,
10245 & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10246 & AVERII,AVERK,AVERJ,AVERL,AVERM,
10247 & AVERI+AVERK+AVERL+AVERM
10248 WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10249 & 'standard deviation ( sqrt(sigma) ):',
10250 & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10251 & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10252 & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10253 WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
10254 DO I=0,MIN(IMAX,KMAX)
10255 WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10256 & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10257 ENDDO
10258
10259C cross check of probability distribution and inclusive cross section
10260 PSsum_1 = 0.D0
10261 PSsum_2 = 0.D0
10262 PHsum_1 = 0.D0
10263 PHsum_2 = 0.D0
10264 do i=1,IMAX
10265 PSsum_1 = PSsum_1+PSOFT(i)*FAC
10266 PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10267 enddo
10268 do k=1,KMAX
10269 PHsum_1 = PHsum_1+PHARD(k)
10270 PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10271 enddo
10272 WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10273 & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10274
10275 ENDIF
10276
10277 END
10278
10279*$ CREATE PHO_SAMPRO.FOR
10280*COPY PHO_SAMPRO
10281CDECK ID>, PHO_SAMPRO
10282 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10283C***********************************************************************
10284C
10285C routine to sample kind of process
10286C
10287C input: IP particle combination
10288C IFP1/2 PDG number of particle 1/2
10289C ECM c.m. energy (GeV)
10290C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10291C SPROB suppression factor for processes 1-7
10292C due to rapidity gap survival probability
10293C IPROC mode
10294C -2 output of statistics
10295C -1 initialization
10296C 0 sampling of process
10297C
10298C output: IPROC kind of interaction process:
10299C 1 non-diffractive resolved process
10300C 2 elastic scattering
10301C 3 quasi-elastic rho/omega/phi production
10302C 4 central diffraction
10303C 5 single diffraction according to IDIFF1
10304C 6 single diffraction according to IDIFF2
10305C 7 double diffraction
10306C 8 single-resolved / direct processes
10307C
10308C***********************************************************************
10309 IMPLICIT NONE
10310 SAVE
10311
10312 INTEGER IP,IFP1,IFP2,IPROC
10313 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10314
10315C input/output channels
10316 INTEGER LI,LO
10317 COMMON /POINOU/ LI,LO
10318C event debugging information
10319 INTEGER NMAXD
10320 PARAMETER (NMAXD=100)
10321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10325C cross sections
10326 INTEGER IPFIL,IFAFIL,IFBFIL
10327 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10328 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10329 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10330 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10331 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10332 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10333 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10334 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10335 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10336 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10337 & IPFIL,IFAFIL,IFBFIL
10338C model switches and parameters
10339 CHARACTER*8 MDLNA
10340 INTEGER ISWMDL,IPAMDL
10341 DOUBLE PRECISION PARMDL
10342 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10343C general process information
10344 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10345 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10346C event weights and generated cross section
10347 INTEGER IPOWGC,ISWCUT,IVWGHT
10348 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10349 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10350 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10351
10352 DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10353 DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10354 DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10355
10356 INTEGER I,K,KMAX
10357 DOUBLE PRECISION DT_RNDM
10358 DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10359
10360 IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10361 & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10362 & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10363
10364 IF(IPROC.GE.0) THEN
10365
10366C interpolate cross sections
10367 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10368
10369C cross check
10370 IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10371 WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10372 & 'PHO_SAMPRO: inconsistent gap survival probability',
10373 & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10374 & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10375 ENDIF
10376
10377C calculate cumulative probabilities
10378 IF(ISWMDL(1).EQ.3) THEN
10379 IF(ISWMDL(2).GE.1) THEN
10380 SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10381 SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10382 SIGDDI = SIGLDD+SIGHDD
10383 SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10384 & - SIGSDI(1)-SIGSDI(2)-SIGDDI
10385 XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10386 XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10387 XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10388 XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10389 XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10390 XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10391 XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10392 XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10393 ELSE
10394 SIGHR = 0.D0
10395 IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10396 SIGHD = 0.D0
10397 IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10398 XPROB(1) = SIGHR/(SIGHR+SIGHD)
10399 XPROB(2) = XPROB(1)
10400 XPROB(3) = XPROB(1)
10401 XPROB(4) = XPROB(1)
10402 XPROB(5) = XPROB(1)
10403 XPROB(6) = XPROB(1)
10404 XPROB(7) = XPROB(1)
10405 XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10406 ENDIF
10407
10408 IF(IDEB(11).GE.15) THEN
10409 WRITE(LO,'(1X,A,I3)')
10410 & 'PHO_SAMPRO: partial cross sections for IP',IP
10411 WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10412 DO 240 I=2,8
10413 WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10414 240 CONTINUE
10415 ENDIF
10416
10417 ELSE
10418 WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10419 & ISWMDL(1)
10420 CALL PHO_ABORT
10421 ENDIF
10422
10423 IF(XPROB(8).LT.1.D-20) THEN
10424 IF(IDEB(11).GE.2)
10425 & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10426 & 'activated processes have vanishing cross section sum',
10427 & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10428 IPROC = 0
10429 RETURN
10430 ENDIF
10431
10432C sample process
10433 XI = DT_RNDM(XI)*XPROB(8)
10434 DO 100 I=1,8
10435 IF(XI.LE.XPROB(I)) GOTO 110
10436 100 CONTINUE
10437 110 CONTINUE
10438 IPROC = MIN(I,8)
10439
10440 CALLS(IP) = CALLS(IP)+1.D0
10441 PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10442 ECMSUM(IP) = ECMSUM(IP)+ECM
10443 IF(ISWMDL(2).GE.1) THEN
10444 SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10445 ELSE
10446 SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10447 ENDIF
10448
10449C debug output
10450 IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10451 & 'PHO_SAMPRO: IP,CALL,PROC-ID',
10452 & IP,INT(CALLS(IP)+0.1D0),IPROC
10453
10454C statistics initialization
10455 ELSE IF(IPROC.EQ.-1) THEN
10456 DO 260 K=1,4
10457 DO 250 I=1,8
10458 PRO(I,K) = 0.D0
10459 250 CONTINUE
10460 CALLS(K) = 0.D0
10461 SIGSUM(K) = 0.D0
10462 ECMSUM(K) = 0.D0
10463 260 CONTINUE
10464
10465C write out statistics
10466 ELSE IF(IPROC.EQ.-2) THEN
10467 KMAX = 4
10468 IF(ISWMDL(2).EQ.0) KMAX=1
10469 DO 270 K=1,KMAX
10470 IF(CALLS(K).GT.0.5D0) THEN
10471 SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10472 ECMSUM(K) = ECMSUM(K)/CALLS(K)
10473 IF(IDEB(11).GE.0) THEN
10474 WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10475 & 'PHO_SAMPRO: internal process statistics ',
10476 & '(IP,<Ecm>)',K,ECMSUM(K),
10477 & '---------------------------------------'
10478 WRITE(LO,'(8X,A)')
10479 & ' process sampled cross section'
10480 IF(ISWMDL(2).GE.1) THEN
10481 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10482 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10483 & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10484 & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10485 & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10486 & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10487 & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10488 & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10489 & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10490 & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10491 ELSE
10492 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10493 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10494 & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10495 & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10496 ENDIF
10497 ENDIF
10498 ENDIF
10499 270 CONTINUE
10500 ENDIF
10501
10502 END
10503
10504*$ CREATE PHO_SAMPRB.FOR
10505*COPY PHO_SAMPRB
10506CDECK ID>, PHO_SAMPRB
10507 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10508C********************************************************************
10509C
10510C routine to sample number of cut graphs of different kind
10511C
10512C input: IP scattering particle combination
10513C ECMI CMS energy
10514C IP -1 initialization
10515C -2 output of statistics
10516C others sampling of cuts
10517C
10518C output: ISAM number of soft Pomerons cut
10519C JSAM number of soft Reggeons cut
10520C KSAM number of hard Pomerons cut
10521C
10522C PHO_PRBDIS has to be called before
10523C
10524C********************************************************************
10525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10526 SAVE
10527
10528C input/output channels
10529 INTEGER LI,LO
10530 COMMON /POINOU/ LI,LO
10531C event debugging information
10532 INTEGER NMAXD
10533 PARAMETER (NMAXD=100)
10534 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10535 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10536 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10537 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10538C model switches and parameters
10539 CHARACTER*8 MDLNA
10540 INTEGER ISWMDL,IPAMDL
10541 DOUBLE PRECISION PARMDL
10542 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10543C general process information
10544 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10545 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10546C nucleon-nucleus / nucleus-nucleus interface to DPMJET
10547 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10548 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10549 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10550 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10551C obsolete cut-off information
10552 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10553 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10554C cut probability distribution
10555 INTEGER IEETA1,IIMAX,KKMAX
10556 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10557 INTEGER IEEMAX,IMAX,KMAX
10558 REAL PROB
10559 DOUBLE PRECISION EPTAB
10560 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10561 & IEEMAX,IMAX,KMAX
10562C global event kinematics and particle IDs
10563 INTEGER IFPAP,IFPAB
10564 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10565 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10566C cross sections
10567 INTEGER IPFIL,IFAFIL,IFBFIL
10568 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10569 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10570 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10571 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10572 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10573 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10574 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10575 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10576 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10577 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10578 & IPFIL,IFAFIL,IFBFIL
10579C table of particle indices for recursive PHOJET calls
10580 INTEGER MAXIPX
10581 PARAMETER ( MAXIPX = 100 )
10582 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10583 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10584 & IPOIX1,IPOIX2,IPOIX3
10585
10586 DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10587
10588C sample number of interactions
10589 IF(IP.GE.0) THEN
10590 ITER = 0
10591 ECMX = ECMI
10592 ECMC = ECMI
10593 KLIM = 1
10594 IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10595 IF(IPAMDL(16).EQ.0) ECMC = SECM
10596 KLIM = 0
10597 ENDIF
10598
10599C sample up to kinematic limits only
10600 IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10601 IF(IMAX1.LT.1) THEN
10602 IF(IPAMDL(2).EQ.1) THEN
10603C reggeon allowed
10604 ISAM = 0
10605 JSAM = 1
10606 KSAM = 0
10607 AVERB(3,IP) = AVERB(3,IP)+1.D0
10608 ELSE
10609C only pomeron even at very low energies
10610 ISAM = 1
10611 JSAM = 0
10612 KSAM = 0
10613 AVERB(1,IP) = AVERB(1,IP)+1.D0
10614 ENDIF
10615 AVERB(0,IP) = AVERB(0,IP)+1.D0
10616 GOTO 150
10617 ENDIF
10618C find interpolation factors
10619 IF(ECMX.LE.EPTAB(IP,1)) THEN
10620 I1 = 1
10621 I2 = 1
10622 ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10623 DO 50 I=2,IEEMAX
10624 IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10625 50 CONTINUE
10626 200 CONTINUE
10627 I1 = I-1
10628 I2 = I
10629 ELSE
10630 WRITE(LO,'(/1X,A,2E12.3)')
10631 & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10632 CALL PHO_PREVNT(-1)
10633 I1 = IEEMAX
10634 I2 = IEEMAX
10635 ENDIF
10636 FAC2 = 0.D0
10637 IF(I1.NE.I2)
10638 & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10639 FAC1=1.D0-FAC2
10640C reggeon probability
10641 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10642C calculate soft suppression factor
10643 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10644 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10645C
10646 10 CONTINUE
10647 ITER = ITER+1
10648 XI = DT_RNDM(FAC2)
10649 DO 260 KSAM=0,KMAX
10650 DO 270 ISAM=0,IMAX
10651 PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10652 & +PROB(IP,I2,ISAM,KSAM)*FAC2
10653 IF(PRO.GT.XI) GOTO 100
10654 270 CONTINUE
10655 260 CONTINUE
10656 ISAM = MIN(IMAX,ISAM)
10657 KSAM = MIN(KMAX,KSAM)
10658
10659 100 CONTINUE
10660
10661 IF(ITER.GT.100) THEN
10662
10663 ISAM = 0
10664 JSAM = 1
10665 KSAM = 0
10666 IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10667 & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10668
10669 ELSE
10670
10671C reggeon contribution
10672 JSAM = 0
10673 IF(IPAMDL(2).EQ.1) THEN
10674 DO 90 I=1,ISAM
10675 IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10676 90 CONTINUE
10677 ISAM = ISAM-JSAM
10678 ENDIF
10679C statistics of bare cuts
10680 IF(ITER.EQ.1) THEN
10681 AVERB(0,IP) = AVERB(0,IP)+1.D0
10682 AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10683 AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10684 AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10685 ENDIF
10686C limitation given by field dimensions
10687 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10688
10689 IF(IP.EQ.1) THEN
10690
10691C reweight according to virtualities and PDF treatment
10692 IF(IPAMDL(115).GE.1) THEN
10693 IF(KSAM.EQ.0) THEN
10694 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10695 ENDIF
10696 ENDIF
10697
10698C reduce number of cuts according to photon virtualities
10699 IF(IPAMDL(114).GE.1) THEN
10700 110 CONTINUE
10701 I = ISAM+JSAM
10702 WGX = FSUPP**I
10703 IF(DT_RNDM(WGX).GT.WGX) THEN
10704 IF(ISAM+JSAM+KSAM.GT.1) THEN
10705 IF(JSAM.GT.0) THEN
10706 JSAM = JSAM-1
10707 GOTO 110
10708 ELSE IF(ISAM.GT.0) THEN
10709 ISAM = ISAM-1
10710 GOTO 110
10711 ENDIF
10712 ENDIF
10713 ENDIF
10714 ENDIF
10715
10716 ENDIF
10717
10718C phase space limitation
10719 120 CONTINUE
10720 XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10721 & +DBLE(2*KSAM)*PTCUT(IP)
10722 PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10723 IF(DT_RNDM(XM).GT.PACC) THEN
10724 IF(ISAM+JSAM+KSAM.GT.1) THEN
10725 IF(JSAM.GT.0) THEN
10726 JSAM = JSAM-1
10727 GOTO 120
10728 ELSE IF(ISAM.GT.0) THEN
10729 ISAM = ISAM-1
10730 GOTO 120
10731 ELSE IF(KSAM.GT.KLIM) THEN
10732 KSAM = KSAM-1
10733 GOTO 120
10734 ENDIF
10735 ENDIF
10736 ENDIF
10737
10738 ENDIF
10739
10740 ISAM = ISAM+JSAM/2
10741 JSAM = MOD(JSAM,2)
10742C collect statistics
10743 150 CONTINUE
10744 ECMS1(IP) = ECMS1(IP)+ECMX
10745 ECMS2(IP) = ECMS2(IP)+ECMC
10746 AVERC(0,IP) = AVERC(0,IP)+1.D0
10747 AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10748 AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10749 AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10750C
10751 IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10752 & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10753C
10754C initialize statistics
10755 ELSE IF(IP.EQ.-1) THEN
10756 DO 60 I=1,4
10757 ECMS1(I) = 0.D0
10758 ECMS2(I) = 0.D0
10759 DO 65 K=0,3
10760 AVERB(K,I) = 0.D0
10761 AVERC(K,I) = 0.D0
10762 65 CONTINUE
10763 60 CONTINUE
10764 RETURN
10765C
10766C write out statistics
10767 ELSE IF(IP.EQ.-2) THEN
10768 WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10769 & '----------------------------------'
10770 DO 70 I=1,4
10771 IF(AVERB(0,I).LT.2.D0) GOTO 75
10772 WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10773 & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10774 & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10775 WRITE(LO,'(5X,A)')
10776 & 'average number of s-pom,h-pom,reg cuts (bare)'
10777 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10778 & (AVERB(K,I)/AVERB(0,I),K=1,3)
10779 WRITE(LO,'(5X,A)')
10780 & 'average (with energy/virtuality corrections)'
10781 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10782 & (AVERC(K,I)/AVERC(0,I),K=1,3)
10783
10784 75 CONTINUE
10785 70 CONTINUE
10786 RETURN
10787 ENDIF
10788 END
10789
10790*$ CREATE PHO_TRIREG.FOR
10791*COPY PHO_TRIREG
10792CDECK ID>, PHO_TRIREG
10793 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10794 & SIGTR,BTR)
10795C**********************************************************************
10796C
10797C calculation of triple-Pomeron total cross section
10798C according to Gribov's Regge theory
10799C
10800C input: S squared cms energy
10801C GA coupling constant to diffractive line
10802C AA slope related to GA (GeV**-2)
10803C GB coupling constant to elastic line
10804C BB slope related to GB (GeV**-2)
10805C DELTA effective pomeron delta (intercept-1)
10806C ALPHAP slope of pomeron trajectory (GeV**-2)
10807C GPPP triple-Pomeron coupling
10808C BPPP slope related to B0PPP (GeV**-2)
10809C VIR2A virtuality of particle a (GeV**2)
10810C note: units of all coupling constants are mb**1/2
10811C
10812C output: SIGTR total triple-Pomeron cross section
10813C BTR effective triple-Pomeron slope
10814C (differs from diffractive slope!)
10815C
10816C uses E_i (Exponential-Integral function)
10817C
10818C**********************************************************************
10819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10820 SAVE
10821
10822 PARAMETER (EPS =0.0001D0)
10823
10824C input/output channels
10825 INTEGER LI,LO
10826 COMMON /POINOU/ LI,LO
10827C event debugging information
10828 INTEGER NMAXD
10829 PARAMETER (NMAXD=100)
10830 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10831 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10832 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10833 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10834C some constants
10835 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10836 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10837 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10838
10839C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10840 SIGU = 2.5
10841C integration cut-off Sigma_L (min. squared mass of diff. blob)
10842 SIGL = 5.+VIR2A
10843C debug output
10844 IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10845 & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10846 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10847C
10848 IF(S.LT.5.D0) THEN
10849 SIGTR = 0.D0
10850 BTR = BPPP+BB
10851 RETURN
10852 ENDIF
10853C change units of ALPHAP to mb
10854 ALSCA = ALPHAP*GEV2MB
10855C
10856C cross section
10857 PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10858 & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10859 PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10860 PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10861C
10862 SIGTR=PART1*(PART2-PART3)
10863C
10864C slope
10865 PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10866 & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10867 PART2 = LOG(PART1)
10868 PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10869 BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10870 BTR = BTR-PART1
10871C
10872 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10873 IF(BTR.LT.BB) BTR = BB
10874C
10875 IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10876 & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10877 END
10878
10879*$ CREATE PHO_LOOREG.FOR
10880*COPY PHO_LOOREG
10881CDECK ID>, PHO_LOOREG
10882 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10883 & VIR2A,VIR2B,SIGLO,BLO)
10884C**********************************************************************
10885C
10886C calculation of loop-Pomeron total cross section
10887C according to Gribov's Regge theory
10888C
10889C input: S squared cms energy
10890C GA coupling constant to diffractive line
10891C AA slope related to GA (GeV**-2)
10892C GB coupling constant to elastic line
10893C BB slope related to GB (GeV**-2)
10894C DELTA effective pomeron delta (intercept-1)
10895C ALPHAP slope of pomeron trajectory (GeV**-2)
10896C GPPP triple-Pomeron coupling
10897C BPPP slope related to B0PPP (GeV**-2)
10898C VIR2A virtuality of particle a (GeV**2)
10899C VIR2B virtuality of particle b (GeV**2)
10900C note: units of all coupling constants are mb**1/2
10901C
10902C output: SIGLO total loop-Pomeron cross section
10903C BLO effective loop-Pomeron slope
10904C (differs from double diffractive slope!)
10905C
10906C uses E_i (Exponential-Integral function)
10907C
10908C**********************************************************************
10909 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10910 SAVE
10911
10912 PARAMETER (EPS =0.0001D0)
10913
10914C input/output channels
10915 INTEGER LI,LO
10916 COMMON /POINOU/ LI,LO
10917C event debugging information
10918 INTEGER NMAXD
10919 PARAMETER (NMAXD=100)
10920 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10921 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10922 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10923 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10924C some constants
10925 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10926 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10927 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10928
10929C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10930 SIGU = 2.5
10931C integration cut-off Sigma_L (min. squared mass of diff. blob)
10932 SIGL = 5.+VIR2A+VIR2B
10933C debug output
10934 IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10935 & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10936 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10937C
10938 IF(S.LT.5.D0) THEN
10939 SIGLO = 0.D0
10940 BLO = 2.D0*BPPP
10941 RETURN
10942 ENDIF
10943
10944C
10945C change units of ALPHAP to mb
10946 ALSCA = ALPHAP*GEV2MB
10947C
10948C cross section
10949 PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
10950 & EXP(-DELTA*BPPP/ALPHAP)
10951 PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
10952 PARTB=BPPP/ALPHAP+LOG(SIGU)
10953 SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
10954 & -PHO_EXPINT(PARTB*DELTA))
10955 & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
10956 & )
10957C
10958C slope
10959 PART1 = LOG(ABS(PARTA/PARTB))
10960 & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
10961 PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
10962 BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
10963 BLO = BLO-PART1
10964C
10965 IF(SIGLO.LT.EPS) SIGLO = 0.D0
10966 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10967C
10968 IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10969 & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
10970 END
10971
10972*$ CREATE PHO_TRXPOM.FOR
10973*COPY PHO_TRXPOM
10974CDECK ID>, PHO_TRXPOM
10975 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10976 & GPPP,BPPP,SIGDP,BDP)
10977C**********************************************************************
10978C
10979C calculation of total cross section of two tripe-Pomeron
10980C graphs in X configuration according to Gribov's Reggeon field
10981C theory
10982C
10983C input: S squared cms energy
10984C GA coupling constant to elastic line 1
10985C AA slope related to GA (GeV**-2)
10986C GB coupling constant to elastic line 2
10987C BB slope related to GB (GeV**-2)
10988C DELTA effective pomeron delta (intercept-1)
10989C ALPHAP slope of pomeron trajectory (GeV**-2)
10990C BPPP triple-Pomeron coupling
10991C BTR slope related to B0PPP (GeV**-2)
10992C note: units of all coupling constants are mb**1/2
10993C
10994C output: SIGDP total cross section for double-Pomeron
10995C scattering
10996C BDP effective double-Pomeron slope
10997C
10998C**********************************************************************
10999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11000 SAVE
11001
11002 PARAMETER (EPS =0.0001D0)
11003
11004C input/output channels
11005 INTEGER LI,LO
11006 COMMON /POINOU/ LI,LO
11007C event debugging information
11008 INTEGER NMAXD
11009 PARAMETER (NMAXD=100)
11010 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11011 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11012 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11013 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11014C model switches and parameters
11015 CHARACTER*8 MDLNA
11016 INTEGER ISWMDL,IPAMDL
11017 DOUBLE PRECISION PARMDL
11018 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11019C some constants
11020 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11021 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11022 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11023
11024 DIMENSION XWGH1(96),XPOS1(96)
11025
11026C lower integration cut-off Sigma_L
11027 SIGL = PARMDL(71)**2
11028C upper integration cut-off Sigma_U
11029 C = 1.D0-1.D0/PARMDL(70)**2
11030 C = MAX(PARMDL(72),C)
11031 SIGU = (1.D0-C)**2*S
11032C integration precision
11033 NGAUS1=16
11034C
11035C debug output
11036 IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11037 & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11038 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11039C
11040 IF(SIGU.LE.SIGL) THEN
11041 SIGDP = 0.D0
11042 BDP = AA+BB
11043 RETURN
11044 ENDIF
11045C
11046C cross section
11047C
11048 XIL = LOG(SIGL)
11049 XIU = LOG(SIGU)
11050 XI = LOG(S)
11051 FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11052 ALPHA2 = 2.D0*ALPHAP
11053 ALOC = LOG(1.D0/(1.D0-C))
11054 CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11055 XSUM = 0.D0
11056 DO 100 I1=1,NGAUS1
11057 AMXSQ = EXP(XPOS1(I1))
11058 ALOSMX = LOG(S/AMXSQ)
11059 ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11060 W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11061 W = MAX(0.D0,W)
11062 WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11063C supercritical part
11064 WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11065 XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11066 100 CONTINUE
11067 SIGDP = XSUM*FAC
11068C
11069C slope
11070 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11071C
11072 IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11073 & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11074 END
11075
11076*$ CREATE PHO_CHAN2A.FOR
11077*COPY PHO_CHAN2A
11078CDECK ID>, PHO_CHAN2A
11079 SUBROUTINE PHO_CHAN2A(BB)
11080C***********************************************************************
11081C
11082C simple two channel model to realize low mass diffraction
11083C (version A, iteration of triple- and loop-Pomeron)
11084C
11085C input: BB impact parameter (mb**1/2)
11086C
11087C output: /POINT4/
11088C AMPEL elastic amplitude
11089C AMPVM(4,4) q-elastic VM production
11090C AMLMSD(2) low mass single diffraction amplitude
11091C AMHMSD(2) high mass single diffraction amplitude
11092C AMLMDD low mass double diffraction amplitude
11093C AMHMDD high mass double diffraction amplitude
11094C AMPDP(4) central diffraction amplitude
11095C
11096C***********************************************************************
11097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11098 SAVE
11099
11100 PARAMETER (DEPS = 1.D-5,
11101 & EIGHT = 8.D0)
11102
11103C input/output channels
11104 INTEGER LI,LO
11105 COMMON /POINOU/ LI,LO
11106C event debugging information
11107 INTEGER NMAXD
11108 PARAMETER (NMAXD=100)
11109 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11110 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11111 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11112 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11113C model switches and parameters
11114 CHARACTER*8 MDLNA
11115 INTEGER ISWMDL,IPAMDL
11116 DOUBLE PRECISION PARMDL
11117 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11118C some constants
11119 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11120 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11121 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11122C complex Born graph amplitudes used for unitarization
11123 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11124 & AMHMDD,AMPDP
11125 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11126 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11127C unitarized amplitudes for different diffraction channels
11128 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11129 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11130 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11131 & ZXL,BXL
11132 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11133 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11134 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11135 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11136 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11137 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11138 & ZXL(4,4),BXL(4,4)
11139C Reggeon phenomenology parameters
11140 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11141 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11142 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11143 & ALREG,ALREGP,GR(2),B0REG(2),
11144 & GPPP,GPPR,B0PPP,B0PPR,
11145 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11146C parameters of 2x2 channel model
11147 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11148 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11149C global event kinematics and particle IDs
11150 INTEGER IFPAP,IFPAB
11151 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11152 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11153
11154C local variables
11155 DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11156 & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11157 & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11158 DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11159
11160C combinatorical factors
11161 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11162 & 1.D0,-1.D0, 1.D0,-1.D0,
11163 & 1.D0,-1.D0,-1.D0, 1.D0,
11164 & 1.D0, 1.D0, 1.D0, 1.D0 /
11165 DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11166 & 1.D0,-1.D0,-1.D0, 1.D0,
11167 & -1.D0, 1.D0,-1.D0, 1.D0,
11168 & -1.D0,-1.D0, 1.D0, 1.D0 /
11169 DATA IELTAB / 1, 2, 3, 4,
11170 & 2, 1, 4, 3,
11171 & 3, 4, 1, 2,
11172 & 4, 3, 2, 1 /
11173
11174 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11175 & 'PHO_CHAN2A: impact parameter B',BB
11176
11177 B24 = BB**2/4.D0
11178 DO 25 I=1,4
11179 AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11180 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
11181 AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11182 AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11183 AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11184 AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11185 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11186 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11187 AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11188 AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11189 AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11190 AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11191 25 CONTINUE
11192
11193 DO 50 I=1,4
11194 ABSUM(I) = 0.D0
11195 DO 75 II=9,1,-1
11196 ABSUM(I) = ABSUM(I) + AB(II,I)
11197 75 CONTINUE
11198 50 CONTINUE
11199 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11200 & 'PHO_CHAN2A: ABSUM',ABSUM
11201
11202 DO 100 I=1,4
11203 CHI(I) = 0.D0
11204 CHDS(I) = 0.D0
11205 CHDH(I) = 0.D0
11206 CHDA(I) = 0.D0
11207 CHDB(I) = 0.D0
11208 CHDD(I) = 0.D0
11209 CHDPE(I) = 0.D0
11210 CHDPA(I) = 0.D0
11211 CHDPB(I) = 0.D0
11212 CHDPD(I) = 0.D0
11213 AMPELA(I,0) = 0.D0
11214 AMPELA(I,9) = 0.D0
11215 DO 200 K=1,4
11216 AMPELA(I,K) = 0.D0
11217 AMPELA(I,K+4) = 0.D0
11218 AMPVM(I,K) = 0.D0
11219 CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
11220 CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11221 CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11222 CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11223 CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11224 CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11225 CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11226 CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11227 CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11228 CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11229 200 CONTINUE
11230 IF(CHI(I).LT.-DEPS) THEN
11231 IF(IDEB(86).GE.0) THEN
11232 WRITE(LO,'(1X,A,I3,2E12.3)')
11233 & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11234 WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11235 ENDIF
11236 ENDIF
11237 IF(ABS(CHI(I)).GT.200.D0) THEN
11238 EX1CHI(I) = 0.D0
11239 EX2CHI(I) = 0.D0
11240 ELSE
11241 TMP = EXP(-CHI(I))
11242 EX1CHI(I) = TMP
11243 EX2CHI(I) = TMP*TMP
11244 ENDIF
11245 100 CONTINUE
11246 IF(IDEB(86).GE.20) THEN
11247 WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11248 ENDIF
11249
11250 AMPELA(1,0) = 4.D0
11251 DO 300 K=1,4
11252 DO 400 J=1,4
11253 CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11254 AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11255 AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11256 AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11257 AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11258 AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11259 AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11260 AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11261 AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11262 AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11263 AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11264 400 CONTINUE
11265 300 CONTINUE
11266
11267 IF(IDEB(86).GE.25) THEN
11268 DO 305 I=1,9
11269 WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11270 & (AMPELA(K,1),K=1,4)
11271 305 CONTINUE
11272 ENDIF
11273
11274C VDM factors --> amplitudes
11275C low mass excitations
11276 DO 500 I=1,4
11277 AMPCHA(I) = 0.D0
11278 DO 600 K=1,4
11279 AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11280 600 CONTINUE
11281 500 CONTINUE
11282 AMPVME = AMPCHA(1)/EIGHT
11283 AMLMSD(1) = AMPCHA(2)/EIGHT
11284 AMLMSD(2) = AMPCHA(3)/EIGHT
11285 AMLMDD = AMPCHA(4)/EIGHT
11286C elastic part, high mass diffraction
11287 AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11288 AMPSOF = 0.D0
11289 AMPHAR = 0.D0
11290 AMHMSD(1) = 0.D0
11291 AMHMSD(2) = 0.D0
11292 AMHMDD = 0.D0
11293 AMPDP(1) = 0.D0
11294 AMPDP(2) = 0.D0
11295 AMPDP(3) = 0.D0
11296 AMPDP(4) = 0.D0
11297 DO 450 I=1,4
11298 AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
11299 AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
11300 AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
11301 AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11302 AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11303 AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
11304 AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
11305 AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
11306 AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
11307 AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
11308 450 CONTINUE
11309 AMPSOF = AMPSOF/16.D0
11310 AMPHAR = AMPHAR/16.D0
11311 AMHMSD(1) = AMHMSD(1)/16.D0
11312 AMHMSD(2) = AMHMSD(2)/16.D0
11313 AMHMDD = AMHMDD/16.D0
11314 AMPDP(1) = AMPDP(1)/16.D0
11315 AMPDP(2) = AMPDP(2)/16.D0
11316 AMPDP(3) = AMPDP(3)/16.D0
11317 AMPDP(4) = AMPDP(4)/16.D0
11318 IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11319 IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11320 IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
11321 IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11322 IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11323 IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11324 IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11325
11326C vector-meson production, weight factors
11327 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11328 IF(IFPAP(1).EQ.22) THEN
11329 IF(IFPAP(2).EQ.22) THEN
11330 DO 10 I=1,4
11331 DO 15 J=1,4
11332 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11333 15 CONTINUE
11334 10 CONTINUE
11335 ELSE
11336 AMPVM(1,1) = PARMDL(10)*AMPVME
11337 AMPVM(2,1) = PARMDL(11)*AMPVME
11338 AMPVM(3,1) = PARMDL(12)*AMPVME
11339 AMPVM(4,1) = PARMDL(13)*AMPVME
11340 ENDIF
11341 ELSE IF(IFPAP(2).EQ.22) THEN
11342 AMPVM(1,1) = PARMDL(10)*AMPVME
11343 AMPVM(1,2) = PARMDL(11)*AMPVME
11344 AMPVM(1,3) = PARMDL(12)*AMPVME
11345 AMPVM(1,4) = PARMDL(13)*AMPVME
11346 ENDIF
11347 ENDIF
11348C debug output
11349 IF(IDEB(86).GE.5) THEN
11350 WRITE(LO,'(/,1X,A)')
11351 & 'PHO_CHAN2A: impact parameter amplitudes'
11352 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
11353 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11354 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11355 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11356 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11357 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
11358 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
11359 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
11360 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
11361 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
11362 WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
11363 ENDIF
11364
11365 END
11366
11367*$ CREATE PHO_EVENT.FOR
11368*COPY PHO_EVENT
11369CDECK ID>, PHO_EVENT
11370 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11371C********************************************************************
11372C
11373C main subroutine to manage simulation processes
11374C
11375C input: NEV -1 initialization
11376C 1 generation of events
11377C 2 generation of events without rejection
11378C due to energy dependent cross section
11379C 3 generation of events without rejection
11380C using initialization energy
11381C -2 output of event generation statistics
11382C P1(4) momentum of particle 1 (internal TARGET)
11383C P2(4) momentum of particle 2 (internal PROJECTILE)
11384C FAC used for initialization:
11385C contains cross section the events corresponds to
11386C during generation: current cross section
11387C
11388C output: IREJ 0: event accepted
11389C 1: event rejected
11390C
11391C********************************************************************
11392 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11393 SAVE
11394
11395 PARAMETER ( TINY = 1.D-10 )
11396
11397 DIMENSION P1(4),P2(4)
11398
11399C input/output channels
11400 INTEGER LI,LO
11401 COMMON /POINOU/ LI,LO
11402C event debugging information
11403 INTEGER NMAXD
11404 PARAMETER (NMAXD=100)
11405 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11406 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11407 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11408 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11409C model switches and parameters
11410 CHARACTER*8 MDLNA
11411 INTEGER ISWMDL,IPAMDL
11412 DOUBLE PRECISION PARMDL
11413 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11414C general process information
11415 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11416 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11417C internal rejection counters
11418 INTEGER NMXJ
11419 PARAMETER (NMXJ=60)
11420 CHARACTER*10 REJTIT
11421 INTEGER IFAIL
11422 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11423C gamma-lepton or gamma-hadron vertex information
11424 INTEGER IGHEL,IDPSRC,IDBSRC
11425 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11426 & RADSRC,AMSRC,GAMSRC
11427 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11428 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11429 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11430C global event kinematics and particle IDs
11431 INTEGER IFPAP,IFPAB
11432 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11433 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11434C cross sections
11435 INTEGER IPFIL,IFAFIL,IFBFIL
11436 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11437 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11438 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11439 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11440 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11441 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11442 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11443 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11444 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11445 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11446 & IPFIL,IFAFIL,IFBFIL
11447C event weights and generated cross section
11448 INTEGER IPOWGC,ISWCUT,IVWGHT
11449 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11450 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11451 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11452C names of hard scattering processes
11453 INTEGER Max_pro_1
11454 PARAMETER ( Max_pro_1 = 16 )
11455 CHARACTER*18 PROC
11456 COMMON /POHPRO/ PROC(0:Max_pro_1)
11457C hard cross sections and MC selection weights
11458 INTEGER Max_pro_2
11459 PARAMETER ( Max_pro_2 = 16 )
11460 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11461 & MH_acc_1,MH_acc_2
11462 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11463 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11464 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11465 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11466 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11467 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11468C table of particle indices for recursive PHOJET calls
11469 INTEGER MAXIPX
11470 PARAMETER ( MAXIPX = 100 )
11471 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11472 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11473 & IPOIX1,IPOIX2,IPOIX3
11474
11475 DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11476
11477 IREJ = 0
11478
11479C initializations
11480 IF(NEV.EQ.-1) THEN
11481 WRITE(LO,'(/3(/1X,A))')
11482 & '=======================================================',
11483 & ' ------- initialization of event generation --------',
11484 & '======================================================='
11485 CALL PHO_SETMDL(0,0,-2)
11486C amplitude parameters
11487 CALL PHO_FITPAR(1)
11488 CALL PHO_REJSTA(-1)
11489C initialize MC package
11490 CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11491 CALL PHO_MCINI
11492 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11493 & 0.D0,-1)
11494 CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11495C cross section
11496 FAC = SIGGEN(4)
11497 DO 20 I=1,10
11498 IPRSAM(I) = 0
11499 IPRACC(I) = 0
11500 IENACC(I) = 0
11501 20 CONTINUE
11502 ISPS = 0
11503 ISPA = 0
11504 ISRS = 0
11505 ISRA = 0
11506 IHPS = 0
11507 IHPA = 0
11508 ISTS = 0
11509 ISTA = 0
11510 ISLS = 0
11511 ISLA = 0
11512 IDIS = 0
11513 IDIA = 0
11514 IDPS = 0
11515 IDPA = 0
11516 IDNS(1) = 0
11517 IDNS(2) = 0
11518 IDNS(3) = 0
11519 IDNS(4) = 0
11520 IDNA(1) = 0
11521 IDNA(2) = 0
11522 IDNA(3) = 0
11523 IDNA(4) = 0
11524 KACCEP = 0
11525 KEVENT = 0
11526 KEVGEN = 0
11527 ECMSUM = 0.D0
11528 ELSE IF(NEV.GT.0) THEN
11529C
11530C -------------- begin event generation ---------------
11531C
11532 IPAMDL(13) = 0
11533 IF(NEV.EQ.3) IPAMDL(13) = 1
11534 KEVENT = KEVENT+1
11535C enable debugging
11536 CALL PHO_TRACE(0,0,0)
11537 IF(IDEB(68).GE.2) THEN
11538 IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11539 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11540 ENDIF
11541 CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11542C cross section calculation
11543 FAC = SIGGEN(3)
11544 IF(NEV.EQ.1) THEN
11545 IF(IVWGHT(1).EQ.1) THEN
11546 WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11547 ELSE
11548 WG = SIGGEN(3)/SIGGEN(4)
11549 ENDIF
11550 IF(DT_RNDM(FAC).GT.WG) THEN
11551 IREJ = 1
11552 IF(IDEB(68).GE.6) THEN
11553 WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11554 & 'PHO_EVENT: rejection due to cross section',
11555 & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11556 & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11557 CALL PHO_PREVNT(-1)
11558 ENDIF
11559 RETURN
11560 ENDIF
11561 ENDIF
11562 KEVGEN = KEVGEN+1
11563 SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11564 HSWGHT(0) = MAX(1.D0,WG)
11565
11566 ITRY1 = 0
11567 50 CONTINUE
11568 ITRY1 = ITRY1+1
11569 IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11570
11571C sample process
11572 IPROCE = 0
11573 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11574 & 1.D0,IPROCE)
11575 IF(IPROCE.EQ.0) THEN
11576 IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11577 & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11578 IREJ = 50
11579 RETURN
11580 ENDIF
11581C sampling statistics
11582 IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11583
11584 ITRY2 = 0
11585 60 CONTINUE
11586 ITRY2 = ITRY2+1
11587 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11588C sample number of cut graphs according to IPROCE and
11589C generate parton configurations+strings
11590 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11591C collect statistics
11592 ISPS = ISPS+KSPOM
11593 IHPS = IHPS+KHPOM
11594 ISRS = ISRS+KSREG
11595 ISTS = ISTS+KSTRG+KHTRG
11596 ISLS = ISLS+KSLOO+KHLOO
11597 IDIS = IDIS+MIN(KHDIR,1)
11598 IDPS = IDPS+KHDPO+KSDPO
11599 IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11600 & IDNS(KHDIR) = IDNS(KHDIR)+1
11601C rejection?
11602 IF(IREJ.NE.0) THEN
11603 IF(IDEB(68).GE.4) THEN
11604 WRITE(LO,'(/1X,A,2I5)')
11605 & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11606 CALL PHO_PREVNT(-1)
11607 ENDIF
11608 IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11609 RETURN
11610 ENDIF
11611 IFAIL(1) = IFAIL(1)+1
11612 IF(ITRY1.GT.5) RETURN
11613 IF(IREJ.GE.5) THEN
11614 IF(ISWMDL(2).EQ.0) RETURN
11615 GOTO 50
11616 ENDIF
11617 IF(ITRY2.LT.5) GOTO 60
11618 GOTO 50
11619 ENDIF
11620C fragmentation of strings
11621C FSR and string fragmentation is done separately by DPMJET routines
11622C CALL PHO_STRFRA(IREJ)
11623C rejection?
11624 IF(IREJ.NE.0) THEN
11625 IFAIL(23) = IFAIL(23)+1
11626 IF(IDEB(68).GE.4) THEN
11627 WRITE(LO,'(/1X,A,2I5)')
11628 & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11629 CALL PHO_PREVNT(-1)
11630 ENDIF
11631 GOTO 50
11632 ENDIF
11633C check of conservation of quantum numbers
11634 IF(IDEB(68).GE.-5) THEN
11635 CALL PHO_CHECK(-1,IREJ)
11636 IF(IREJ.NE.0) GOTO 50
11637 ENDIF
11638C event now completely processed and accepted
11639C acceptance statistics
11640 IPRACC(IPROCE) = IPRACC(IPROCE)+1
11641 ISPA = ISPA+KSPOM
11642 IHPA = IHPA+KHPOM
11643 ISRA = ISRA+KSREG
11644 ISTA = ISTA+(KSTRG+KHTRG)
11645 ISLA = ISLA+(KSLOO+KHLOO)
11646 IDIA = IDIA+MIN(KHDIR,1)
11647 IDPA = IDPA+KHDPO+KSDPO
11648 IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11649 & IDNA(KHDIR) = IDNA(KHDIR)+1
11650 DO 55 I=1,IPOIX2
11651 IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11652 55 CONTINUE
11653 KACCEP = KACCEP+1
11654
11655C debug output (partial / full event listing)
11656 if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11657 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11658 IF(IDEB(67).GE.10) THEN
11659 IF(IDEB(67).LE.15) THEN
11660 CALL PHO_PREVNT(-1)
11661 ELSE IF(IDEB(67).LE.20) THEN
11662 CALL PHO_PREVNT(0)
11663 ELSE IF(IDEB(67).LE.25) THEN
11664 CALL PHO_PREVNT(1)
11665 ELSE
11666 CALL PHO_PREVNT(2)
11667 ENDIF
11668 ENDIF
11669C
11670C effective weight
11671 DO 65 I=1,10
11672 IF(IPOWGC(I).GT.0) THEN
11673 HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11674 ENDIF
11675 65 CONTINUE
11676 IF(IVWGHT(1).EQ.1) THEN
11677 WG = HSWGHT(0)
11678 IF(WG.GT.1.01D0) THEN
11679 IF(EVWGHT(1).LT.1.01D0) THEN
11680 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11681 & 'PHO_EVENT: cross section weight > 1',
11682 & KEVENT,KACCEP,WG
11683 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11684 & SIGGEN(3),SIGGEN(4),EVWGHT(1)
11685 ENDIF
11686 EVWGHT(1) = HSWGHT(0)
11687 HSWGHT(0) = 1.D0
11688 ELSE
11689 EVWGHT(1) = 1.D0
11690 ENDIF
11691 ENDIF
11692
11693C effective cross section
11694 SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11695 ECMSUM = ECMSUM+ECM
11696 SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11697 ELSE IF(NEV.EQ.-2) THEN
11698
11699C ---------------- end of event generation ----------------------
11700
11701 WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11702 & '====================================================',
11703 & ' --------- summary of event generation ----------',
11704 & '====================================================',
11705 & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11706 & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11707
11708C write out statistics
11709 IF(KACCEP.GT.0) THEN
11710
11711 FAC1 = SIGGEN(4)/DBLE(KEVENT)
11712 FAC2 = FAC/DBLE(KACCEP)
11713 WRITE(LO,'(/1X,A,/1X,A)')
11714 & 'PHO_EVENT: generated and accepted events',
11715 & '----------------------------------------'
11716 WRITE(LO,'(3X,A)')
11717 & 'process, sampled, accepted, cross section (internal/external)'
11718 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11719 & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11720 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11721 & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11722 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11723 & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11724 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11725 & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11726 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11727 & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11728 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11729 & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11730 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11731 & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11732 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
11733 & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11734 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11735 & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11736 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11737 & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11738 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11739 & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11740 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11741 & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11742 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11743 & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11744 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11745 & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11746 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11747 & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11748 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11749 & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11750 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11751 & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11752 IF(ISWMDL(14).GT.0) THEN
11753 WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11754 & ISWMDL(14)
11755 WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11756 WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11757 WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11758 WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11759 WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11760 ENDIF
11761 WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11762 & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11763
11764 CALL PHO_REJSTA(-2)
11765 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11766 & 0.D0,-2)
11767 CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11768C statistics of hard scattering processes
11769 WRITE(LO,'(2(/1X,A))')
11770 & 'PHO_EVENT: statistics of hard scattering processes',
11771 & '--------------------------------------------------'
11772 DO 43 K=1,4
11773 IF(MH_tried(0,K).GT.0) THEN
11774 WRITE(LO,'(/5X,A,I3)')
11775 & 'process (accepted,x-section internal/external) for IP:',K
11776 DO 47 M=0,Max_pro_2
11777 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11778 & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11779 & DBLE(MH_acc_2(M,K))*FAC2
11780 47 CONTINUE
11781 ENDIF
11782 43 CONTINUE
11783
11784 ELSE
11785 WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11786 ENDIF
11787 WRITE(LO,'(/3(/1X,A)/)')
11788 & '======================================================',
11789 & ' ------- end of event generation summary --------',
11790 & '======================================================'
11791 ELSE
11792 WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11793 ENDIF
11794
11795 END
11796
11797*$ CREATE PHO_PARTON.FOR
11798*COPY PHO_PARTON
11799CDECK ID>, PHO_PARTON
11800 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11801C********************************************************************
11802C
11803C calculation of complete parton configuration
11804C
11805C input: IPROC process ID 1 nondiffractive
11806C 2 elastic
11807C 3 quasi-ela. rho,omega,phi prod.
11808C 4 double Pomeron
11809C 5 single diff 1
11810C 6 single diff 2
11811C 7 double diff diss.
11812C 8 single-resolved / direct photon
11813C JM1,2 index of mother particles in /POEVT1/
11814C
11815C
11816C output: complete parton configuration in /POEVT1/
11817C IREJ 1 failure
11818C 0 success
11819C 50 rejection due to user cutoffs
11820C
11821C********************************************************************
11822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11823 SAVE
11824
11825 DIMENSION P1(4),P2(4)
11826
11827 PARAMETER ( TINY = 1.D-10 )
11828
11829C input/output channels
11830 INTEGER LI,LO
11831 COMMON /POINOU/ LI,LO
11832C event debugging information
11833 INTEGER NMAXD
11834 PARAMETER (NMAXD=100)
11835 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11836 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11837 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11838 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11839C model switches and parameters
11840 CHARACTER*8 MDLNA
11841 INTEGER ISWMDL,IPAMDL
11842 DOUBLE PRECISION PARMDL
11843 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11844C table of particle indices for recursive PHOJET calls
11845 INTEGER MAXIPX
11846 PARAMETER ( MAXIPX = 100 )
11847 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11848 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11849 & IPOIX1,IPOIX2,IPOIX3
11850C general process information
11851 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11852 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11853C global event kinematics and particle IDs
11854 INTEGER IFPAP,IFPAB
11855 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11856 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11857C cross sections
11858 INTEGER IPFIL,IFAFIL,IFBFIL
11859 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11860 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11861 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11862 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11863 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11864 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11865 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11866 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11867 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11868 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11869 & IPFIL,IFAFIL,IFBFIL
11870C event weights and generated cross section
11871 INTEGER IPOWGC,ISWCUT,IVWGHT
11872 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11873 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11874 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11875C internal rejection counters
11876 INTEGER NMXJ
11877 PARAMETER (NMXJ=60)
11878 CHARACTER*10 REJTIT
11879 INTEGER IFAIL
11880 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11881
11882 IREJ = 0
11883C clear event statistics
11884 KSPOM = 0
11885 KHPOM = 0
11886 KSREG = 0
11887 KHDIR = 0
11888 KSTRG = 0
11889 KHTRG = 0
11890 KSLOO = 0
11891 KHLOO = 0
11892 KHARD = 0
11893 KSOFT = 0
11894 KSDPO = 0
11895 KHDPO = 0
11896
11897C-------------------------------------------------------------------
11898C nondiffractive resolved processes
11899
11900 IF(IPROC.EQ.1) THEN
11901C sample number of interactions
11902 555 CONTINUE
11903 IINT = 0
11904 IP = 1
11905C generate only hard events
11906 IF(ISWMDL(2).EQ.0) THEN
11907 MHPOM = 1
11908 MSPOM = 0
11909 MSREG = 0
11910 MHDIR = 0
11911 HSWGHT(1) = 1.D0
11912 ELSE
11913C minimum bias events
11914 IPOWGC(1) = 0
11915 10 CONTINUE
11916 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11917 IPOWGC(1) = IPOWGC(1)+1
11918 MINT = 0
11919 MHDIR = 0
11920 MSTRG = 0
11921 MSLOO = 0
11922C
11923C resolved soft processes: pomeron and reggeon
11924 MSPOM = IINT
11925 MSREG = JINT
11926C resolved hard process: hard pomeron
11927 MHPOM = KINT
11928C resolved absorptive corrections
11929 MPTRI = 0
11930 MPLOO = 0
11931C restrictions given by user
11932 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11933 IF(MSREG.LT.ISWCUT(2)) GOTO 10
11934 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11935 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11936C ----------------------------
11937 IF(ISWMDL(15).EQ.0) THEN
11938 MHPOM = 0
11939 IF(MSREG.GT.0) THEN
11940 MSPOM = 0
11941 MSREG = 1
11942 ELSE
11943 MSPOM = 1
11944 MSREG = 0
11945 ENDIF
11946 ELSE IF(ISWMDL(15).EQ.1) THEN
11947 IF(MHPOM.GT.0) THEN
11948 MHPOM = 1
11949 MSPOM = 0
11950 MSREG = 0
11951 ELSE IF(MSPOM.GT.0) THEN
11952 MSPOM = 1
11953 MSREG = 0
11954 ELSE
11955 MSREG = 1
11956 ENDIF
11957 ELSE IF(ISWMDL(15).EQ.2) THEN
11958 MHPOM = MIN(1,MHPOM)
11959 ELSE IF(ISWMDL(15).EQ.3) THEN
11960 MSPOM = MIN(1,MSPOM)
11961 ENDIF
11962 ENDIF
11963C ----------------------------
11964
11965C statistics
11966 ISPS = ISPS+MSPOM
11967 IHPS = IHPS+MHPOM
11968 ISRS = ISRS+MSREG
11969 ISTS = ISTS+MSTRG
11970 ISLS = ISLS+MSLOO
11971
11972 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11973 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11974 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11975
11976 ITRY2 = 0
11977 50 CONTINUE
11978 ITRY2 = ITRY2+1
11979 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11980 KSPOM = MSPOM
11981 KSREG = MSREG
11982 KHPOM = MHPOM
11983 KHDIR = MHDIR
11984 KSTRG = MPTRI
11985 KSLOO = MPLOO
11986
11987 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11988 IF(IREJ.NE.0) THEN
11989 IF(IREJ.EQ.50) RETURN
11990 IF(IDEB(3).GE.2) THEN
11991 WRITE(LO,'(/1X,A,I5)')
11992 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11993 CALL PHO_PREVNT(-1)
11994 ENDIF
11995 RETURN
11996 ENDIF
11997 IF(MHPOM.GT.0) THEN
11998 IDNODF = 3
11999 ELSE IF(MSPOM.GT.0) THEN
12000 IDNODF = 2
12001 ELSE
12002 IDNODF = 1
12003 ENDIF
12004C check of quantum numbers of parton configurations
12005 IF(IDEB(3).GE.0) THEN
12006 CALL PHO_CHECK(1,IREJ)
12007 IF(IREJ.NE.0) GOTO 50
12008 ENDIF
12009C sample strings to prepare fragmentation
12010 CALL PHO_STRING(1,IREJ)
12011 IF(IREJ.NE.0) THEN
12012 IF(IREJ.EQ.50) RETURN
12013 IFAIL(30) = IFAIL(30)+1
12014 IF(IDEB(3).GE.2) THEN
12015 WRITE(LO,'(/1X,A,I5)')
12016 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12017 CALL PHO_PREVNT(-1)
12018 ENDIF
12019 IF(ITRY2.LT.20) GOTO 50
12020 IF(IDEB(3).GE.1) THEN
12021 WRITE(LO,'(/1X,A,I5)')
12022 & 'PHO_PARTON: rejection',ITRY2
12023 CALL PHO_PREVNT(-1)
12024 ENDIF
12025 RETURN
12026 ENDIF
12027
12028C statistics
12029 ISPA = ISPA+KSPOM
12030 IHPA = IHPA+KHPOM
12031 ISRA = ISRA+KSREG
12032 ISTA = ISTA+KSTRG
12033 ISLA = ISLA+KSLOO
12034
12035C-------------------------------------------------------------------
12036C elastic scattering / quasi-elastic rho/omega/phi production
12037
12038 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12039 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12040 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12041
12042C DPMJET call with special projectile / target: transform into CMS
12043 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12044 & CALL PHO_DFWRAP(1,JM1,JM2)
12045
12046 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12047
12048 IF(IREJ.NE.0) THEN
12049C DPMJET call with special projectile / target: clean up
12050 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12051 & CALL PHO_DFWRAP(-2,JM1,JM2)
12052 IF(IDEB(3).GE.2) THEN
12053 WRITE(LO,'(/1X,A,I5)')
12054 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12055 CALL PHO_PREVNT(-1)
12056 ENDIF
12057 RETURN
12058 ENDIF
12059
12060C DPMJET call with special projectile / target: transform back
12061 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12062 & CALL PHO_DFWRAP(2,JM1,JM2)
12063
12064C prepare possible decays
12065 CALL PHO_STRING(1,IREJ)
12066 IF(IREJ.NE.0) THEN
12067 IF(IREJ.EQ.50) RETURN
12068 IFAIL(30) = IFAIL(30)+1
12069 RETURN
12070 ENDIF
12071
12072C---------------------------------------------------------------------
12073C double Pomeron scattering
12074
12075 ELSE IF(IPROC.EQ.4) THEN
12076 MSOFT = 0
12077 MHARD = 0
12078 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12079 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12080 IDPS = IDPS+1
12081 ITRY2 = 0
12082 60 CONTINUE
12083 ITRY2 = ITRY2+1
12084 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12085C
12086 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12087 IF(IREJ.NE.0) THEN
12088 IF(IDEB(3).GE.2) THEN
12089 WRITE(LO,'(/1X,A,I5)')
12090 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12091 CALL PHO_PREVNT(-1)
12092 ENDIF
12093 RETURN
12094 ENDIF
12095C check of quantum numbers of parton configurations
12096 IF(IDEB(3).GE.0) THEN
12097 CALL PHO_CHECK(1,IREJ)
12098 IF(IREJ.NE.0) GOTO 60
12099 ENDIF
12100C sample strings to prepare fragmentation
12101 CALL PHO_STRING(1,IREJ)
12102 IF(IREJ.NE.0) THEN
12103 IF(IREJ.EQ.50) RETURN
12104 IFAIL(30) = IFAIL(30)+1
12105 IF(IDEB(3).GE.2) THEN
12106 WRITE(LO,'(/1X,A,I5)')
12107 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12108 CALL PHO_PREVNT(-1)
12109 ENDIF
12110 IF(ITRY2.LT.10) GOTO 60
12111 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12112 CALL PHO_PREVNT(-1)
12113 RETURN
12114 ENDIF
12115 IDPA = IDPA+1
12116
12117C-----------------------------------------------------------------------
12118C single / double diffraction dissociation
12119
12120 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12121 MSOFT = 0
12122 MHARD = 0
12123 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12124 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12125 IF(IPROC.EQ.5) ID1S = ID1S+1
12126 IF(IPROC.EQ.6) ID2S = ID2S+1
12127 IF(IPROC.EQ.7) ID3S = ID3S+1
12128 ITRY2 = 0
12129 70 CONTINUE
12130 ITRY2 = ITRY2+1
12131 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12132 IPAR1 = 1
12133 IPAR2 = 1
12134 IF(IPROC.EQ.5) IPAR2 = 0
12135 IF(IPROC.EQ.6) IPAR1 = 0
12136C calculate rapidity gap survival probability
12137 SPROB = 1.D0
12138 IF(ECM.GT.10.D0) THEN
12139 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12140 IF(SIGTR1(1).LT.1.D-10) THEN
12141 SPROB = 1.D0
12142 ELSE
12143 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12144 ENDIF
12145 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12146 IF(SIGTR2(1).LT.1.D-10) THEN
12147 SPROB = 1.D0
12148 ELSE
12149 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12150 ENDIF
12151 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12152 IF(SIGLOO.LT.1.D-10) THEN
12153 SPROB = 1.D0
12154 ELSE
12155 SPROB = SIGHDD/SIGLOO
12156 ENDIF
12157 ENDIF
12158 ENDIF
12159**sr
12160* temporary patch, r.e. 8.6.99
12161 SPROB = 1.D0
12162**
12163
12164C DPMJET call with special projectile / target: transform into CMS
12165 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12166 & CALL PHO_DFWRAP(1,JM1,JM2)
12167
12168 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12169
12170 IF(IREJ.NE.0) THEN
12171C DPMJET call with special projectile / target: clean up
12172 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12173 & CALL PHO_DFWRAP(-2,JM1,JM2)
12174 IF(IDEB(3).GE.2) THEN
12175 WRITE(LO,'(/1X,A,I5)')
12176 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12177 CALL PHO_PREVNT(-1)
12178 ENDIF
12179 RETURN
12180 ENDIF
12181
12182C DPMJET call with special projectile / target: transform back
12183 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12184 & CALL PHO_DFWRAP(2,JM1,JM2)
12185
12186C check of quantum numbers of parton configurations
12187 IF(IDEB(3).GE.0) THEN
12188 CALL PHO_CHECK(1,IREJ)
12189 IF(IREJ.NE.0) GOTO 70
12190 ENDIF
12191C sample strings to prepare fragmentation
12192 CALL PHO_STRING(1,IREJ)
12193 IF(IREJ.NE.0) THEN
12194 IF(IREJ.EQ.50) RETURN
12195 IFAIL(30) = IFAIL(30)+1
12196 IF(IDEB(3).GE.2) THEN
12197 WRITE(LO,'(/1X,A,I5)')
12198 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12199 CALL PHO_PREVNT(-1)
12200 ENDIF
12201 IF(ITRY2.LT.10) GOTO 70
12202 WRITE(LO,'(/1X,A,I5)')
12203 & 'PHO_PARTON: rejection',ITRY2
12204 CALL PHO_PREVNT(-1)
12205 RETURN
12206 ENDIF
12207 IF(IPROC.EQ.5) ID1A = ID1A+1
12208 IF(IPROC.EQ.6) ID2A = ID2A+1
12209 IF(IPROC.EQ.7) ID3A = ID3A+1
12210
12211C-----------------------------------------------------------------------
12212C single / double direct processes
12213
12214 ELSE IF(IPROC.EQ.8) THEN
12215 MSREG = 0
12216 MSPOM = 0
12217 MHPOM = 0
12218 MHDIR = 1
12219 IF(IDEB(3).GE.5) THEN
12220 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12221 ENDIF
12222 IDIS = IDIS+MHDIR
12223 ITRY2 = 0
12224 80 CONTINUE
12225 ITRY2 = ITRY2+1
12226 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12227 KSPOM = MSPOM
12228 KSREG = MSREG
12229 KHPOM = MHPOM
12230 KHDIR = 4
12231
12232 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12233 IF(IREJ.NE.0) THEN
12234 IF(IREJ.EQ.50) RETURN
12235 IF(IDEB(3).GE.2) THEN
12236 WRITE(LO,'(/1X,A,I5)')
12237 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12238 CALL PHO_PREVNT(-1)
12239 ENDIF
12240 RETURN
12241 ENDIF
12242 IDNODF = 4
12243C check of quantum numbers of parton configurations
12244 IF(IDEB(3).GE.0) THEN
12245 CALL PHO_CHECK(1,IREJ)
12246 IF(IREJ.NE.0) GOTO 80
12247 ENDIF
12248C sample strings to prepare fragmentation
12249 CALL PHO_STRING(1,IREJ)
12250 IF(IREJ.NE.0) THEN
12251 IF(IREJ.EQ.50) RETURN
12252 IFAIL(30) = IFAIL(30)+1
12253 IF(IDEB(3).GE.2) THEN
12254 WRITE(LO,'(/1X,A,I5)')
12255 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12256 CALL PHO_PREVNT(-1)
12257 ENDIF
12258 IF(ITRY2.LT.10) GOTO 80
12259 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12260 CALL PHO_PREVNT(-1)
12261 RETURN
12262 ENDIF
12263 IF(IPROC.EQ.5) ID1A = ID1A+1
12264 IF(IPROC.EQ.6) ID2A = ID2A+1
12265 IF(IPROC.EQ.7) ID3A = ID3A+1
12266 IDIA = IDIA+MHDIR
12267
12268C-----------------------------------------------------------------------
12269C initialize control statistics
12270
12271 ELSE IF(IPROC.EQ.-1) THEN
12272 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12273 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12274 CALL PHO_SEAFLA(-1,0,0,DUM)
12275 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12276 & CALL PHO_QELAST(-1,1,2,0)
12277 ISPS = 0
12278 ISPA = 0
12279 ISRS = 0
12280 ISRA = 0
12281 IHPS = 0
12282 IHPA = 0
12283 ISTS = 0
12284 ISTA = 0
12285 ISLS = 0
12286 ISLA = 0
12287 ID1S = 0
12288 ID1A = 0
12289 ID2S = 0
12290 ID2A = 0
12291 ID3S = 0
12292 ID3A = 0
12293 IDPS = 0
12294 IDPA = 0
12295 IDIS = 0
12296 IDIA = 0
12297 CALL PHO_STRING(-1,IREJ)
12298 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12299 RETURN
12300
12301C-----------------------------------------------------------------------
12302C produce statistics summary
12303
12304 ELSE IF(IPROC.EQ.-2) THEN
12305 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12306 IF(IDEB(3).GE.0) THEN
12307 WRITE(LO,'(/1X,A,/1X,A)')
12308 & 'PHO_PARTON: internal statistics on parton configurations',
12309 & '--------------------------------------------------------'
12310 WRITE(LO,'(5X,A)') 'process sampled accepted'
12311 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12312 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12313 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12314 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12315 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12316 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12317 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12318 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12319 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12320 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12321 ENDIF
12322 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12323 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12324 & CALL PHO_QELAST(-2,1,2,0)
12325 CALL PHO_STRING(-2,IREJ)
12326 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12327 CALL PHO_SEAFLA(-2,0,0,DUM)
12328 RETURN
12329 ELSE
12330 WRITE(LO,'(1X,A,I2)')
12331 & 'PARTON:ERROR: unknown process ID ',IPROC
12332 STOP
12333 ENDIF
12334
12335 END
12336
12337*$ CREATE PHO_MCINI.FOR
12338*COPY PHO_MCINI
12339CDECK ID>, PHO_MCINI
12340 SUBROUTINE PHO_MCINI
12341C********************************************************************
12342C
12343C initialization of MC event generation
12344C
12345C********************************************************************
12346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12347 SAVE
12348
12349 PARAMETER ( PIMASS = 0.13D0,
12350 & TINY = 1.D-10 )
12351
12352C input/output channels
12353 INTEGER LI,LO
12354 COMMON /POINOU/ LI,LO
12355C event debugging information
12356 INTEGER NMAXD
12357 PARAMETER (NMAXD=100)
12358 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12359 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12360 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12361 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12362C model switches and parameters
12363 CHARACTER*8 MDLNA
12364 INTEGER ISWMDL,IPAMDL
12365 DOUBLE PRECISION PARMDL
12366 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12367C general process information
12368 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12369 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12370C cross sections
12371 INTEGER IPFIL,IFAFIL,IFBFIL
12372 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12373 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12374 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12375 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12376 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12377 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12378 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12379 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12380 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12381 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12382 & IPFIL,IFAFIL,IFBFIL
12383C hard cross sections and MC selection weights
12384 INTEGER Max_pro_2
12385 PARAMETER ( Max_pro_2 = 16 )
12386 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12387 & MH_acc_1,MH_acc_2
12388 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12389 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12390 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12391 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12392 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12393 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12394C interpolation tables for hard cross section and MC selection weights
12395 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12396 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12397 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12398 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12399 & HQ2a_tab,HQ2b_tab,HEcm_tab
12400 COMMON /POHTAB/
12401 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12402 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12403 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12404 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12405 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12406 & HEcm_tab(1:Max_tab_E,0:4),
12407 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12408C global event kinematics and particle IDs
12409 INTEGER IFPAP,IFPAB
12410 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12411 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12412C obsolete cut-off information
12413 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12414 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12415C event weights and generated cross section
12416 INTEGER IPOWGC,ISWCUT,IVWGHT
12417 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12418 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12419 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12420C cut probability distribution
12421 INTEGER IEETA1,IIMAX,KKMAX
12422 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12423 INTEGER IEEMAX,IMAX,KMAX
12424 REAL PROB
12425 DOUBLE PRECISION EPTAB
12426 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12427 & IEEMAX,IMAX,KMAX
12428C energy-interpolation table
12429 INTEGER IEETA2
12430 PARAMETER ( IEETA2 = 20 )
12431 INTEGER ISIMAX
12432 DOUBLE PRECISION SIGTAB,SIGECM
12433 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12434
12435 CHARACTER*15 PHO_PNAME
12436 DIMENSION ECMF(4)
12437
12438 DATA XMPOM / 0.766D0 /
12439
12440C initialize fragmentation
12441 CALL PHO_FRAINI(ISWMDL(6))
12442
12443C reset interpolation tables
12444 DO 50 I=1,4
12445 DO 60 J=1,10
12446 DO 70 K=1,70
12447 SIGTAB(I,K,J) = 0.D0
12448 70 CONTINUE
12449 SIGECM(I,J) = 0.D0
12450 60 CONTINUE
12451 50 CONTINUE
12452
12453C max. number of allowed colors (large N expansion)
12454 IC1 = 0
12455 IC2 = 10000
12456 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12457
12458C lower energy limit of initialization
12459 ETABLO = PARMDL(19)
12460 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12461
12462 WRITE(LO,'(/,1X,A,2F12.1)')
12463 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12464 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12465 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12466 & PMASS(1),PVIRT(1)
12467 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12468 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12469 & PMASS(2),PVIRT(2)
12470
12471C cuts on probabilities of multiple interactions
12472 IMAX = MIN(IPAMDL(32),IIMAX)
12473 KMAX = MIN(IPAMDL(33),KKMAX)
12474 AH = 2.D0*PTCUT(1)/ECM
12475 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12476 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12477
12478C hard interpolation table
12479 ECMF(1) = ECM
12480 ECMF(2) = 0.9D0*ECMF(1)
12481 ECMF(3) = ECMF(2)
12482 ECMF(4) = ECMF(2)
12483 do k=1,4
12484 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12485 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12486 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12487 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12488 enddo
12489
12490C initialization of hard scattering for all channels and cutoffs
12491 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12492 I0 = 4
12493 IF(ISWMDL(2).EQ.0) I0 = 1
12494 DO 110 I=I0,1,-1
12495 CALL PHO_HARMCI(I,ECMF(I))
12496 110 CONTINUE
12497
12498C dimension of interpolation table of cut probabilities
12499 IEEMAX = MIN(IPAMDL(31),IEETA1)
12500 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12501 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12502 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12503 ISIMAX = IEEMAX
12504
12505C calculate probability distribution
12506 I0 = 4
12507 IFT1 = IFPAP(1)
12508 IFT2 = IFPAP(2)
12509 XMT1 = PMASS(1)
12510 XMT2 = PMASS(2)
12511 XVT1 = PVIRT(1)
12512 XVT2 = PVIRT(2)
12513 IF(ISWMDL(2).EQ.0) I0 = 1
12514 DO 150 IP=I0,1,-1
12515 ECMPRO = ECMF(IP)*1.001D0
12516 IF(IP.EQ.4) THEN
12517 IFPAP(1) = 990
12518 IFPAP(2) = 990
12519 PMASS(1) = XMPOM
12520 PMASS(2) = XMPOM
12521 PVIRT(1) = 0.D0
12522 PVIRT(2) = 0.D0
12523 ELSE IF(IP.EQ.3) THEN
12524 IFPAP(1) = IFT2
12525 IFPAP(2) = 990
12526 PMASS(1) = XMT2
12527 PMASS(2) = XMPOM
12528 PVIRT(1) = XVT2
12529 PVIRT(2) = 0.D0
12530 ELSE IF(IP.EQ.2) THEN
12531 IFPAP(1) = IFT1
12532 IFPAP(2) = 990
12533 PMASS(1) = XMT1
12534 PMASS(2) = XMPOM
12535 PVIRT(1) = XVT1
12536 PVIRT(2) = 0.D0
12537 ELSE
12538 IFPAP(1) = IFT1
12539 IFPAP(2) = IFT2
12540 PMASS(1) = XMT1
12541 PMASS(2) = XMT2
12542 PVIRT(1) = XVT1
12543 PVIRT(2) = XVT2
12544 ENDIF
12545 IF(IEEMAX.GT.1) THEN
12546 IF(IP.EQ.1) THEN
12547 ELMIN = LOG(ETABLO)
12548 ELSE
12549 ELMIN = LOG(2.5D0)
12550 ENDIF
12551 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12552 DO 100 I=1,IEEMAX
12553 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12554 CALL PHO_PRBDIS(IP,ECMPRO,I)
12555 100 CONTINUE
12556 ELSE
12557 CALL PHO_PRBDIS(IP,ECMPRO,1)
12558 ENDIF
12559
12560C debug output of cross section tables
12561 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12562 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12563 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12564 &'Table of total cross sections (mb) for particle combination',IP,
12565 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12566 &'-------------------------------------------------------------'
12567 DO 200 I=1,IEEMAX
12568 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12569 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12570 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12571 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12572 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12573 200 CONTINUE
12574 201 CONTINUE
12575 IF(IDEB(62).GE.2) THEN
12576 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12577 &'Table of partial x-sections (mb) for particle combination',IP,
12578 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12579 &'--------------------------------------------------------------'
12580 DO 205 I=1,IEEMAX
12581 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12582 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12583 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12584 205 CONTINUE
12585 ENDIF
12586 IF(IDEB(62).GE.2) THEN
12587 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12588 &'Table of born graph x-sections (mb) for particle combination',IP,
12589 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12590 &'-------------------------------------------------------------'
12591 DO 210 I=1,IEEMAX
12592 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12593 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12594 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12595 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12596 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12597 & +SIGTAB(IP,68,I)
12598 210 CONTINUE
12599 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12600 &'Table of unitarized x-sections (mb) for particle combination',IP,
12601 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12602 &'-------------------------------------------------------------'
12603 DO 215 I=1,IEEMAX
12604 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12605 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12606 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12607 215 CONTINUE
12608 ENDIF
12609 IF(IDEB(62).GE.1) THEN
12610 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12611 &'Table of expected average number of cuts in non-diff events:',
12612 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12613 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12614 &'---------------------------------------------'
12615 DO 220 I=1,IEEMAX
12616 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12617 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12618 & SIGTAB(IP,76,I)
12619 220 CONTINUE
12620 IF(IP.EQ.1) THEN
12621 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12622 & 'Table of rapidity gap survival probability (high-mass diff.):',
12623 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12624 & '---------------------------------------------------'
12625 DO 230 I=1,IEEMAX
12626 IF(SIGECM(IP,I).GT.10.D0) THEN
12627 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12628 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12629 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12630 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12631 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12632 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12633 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12634 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12635 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12636 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12637 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12638 ENDIF
12639 230 CONTINUE
12640 ENDIF
12641 ENDIF
12642 ENDIF
12643 150 CONTINUE
12644
12645C simulate only hard scatterings
12646 IF(ISWMDL(2).EQ.0) THEN
12647 WRITE(LO,'(2(/1X,A))')
12648 & 'WARNING: generation of hard scatterings only!',
12649 & '============================================='
12650 DO 151 I=2,7
12651 IPRON(I,1) = 0
12652 151 CONTINUE
12653 DO 152 K=2,4
12654 DO 153 I=1,15
12655 IPRON(I,K) = 0
12656 153 CONTINUE
12657 152 CONTINUE
12658 SIGGEN(4) = 0.D0
12659 DO 160 I=1,IEEMAX
12660 SIGMAX = 0.D0
12661 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12662 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12663 IF(SIGMAX.GT.SIGGEN(4)) THEN
12664 ISIGM = I
12665 SIGGEN(4) = SIGMAX
12666 ENDIF
12667 160 CONTINUE
12668 ELSE
12669 WRITE(LO,'(2(/1X,A))')
12670 & 'activated processes, cross section',
12671 & '----------------------------------'
12672 WRITE(LO,'(5X,A,I3,2X,3I3)')
12673 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12674 WRITE(LO,'(5X,A,I3,2X,3I3)')
12675 & ' elastic scattering',(IPRON(2,K),K=1,4)
12676 WRITE(LO,'(5X,A,I3,2X,3I3)')
12677 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12678 WRITE(LO,'(5X,A,I3,2X,3I3)')
12679 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12680 WRITE(LO,'(5X,A,I3,2X,3I3)')
12681 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12682 WRITE(LO,'(5X,A,I3,2X,3I3)')
12683 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12684 WRITE(LO,'(5X,A,I3,2X,3I3)')
12685 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12686 WRITE(LO,'(5X,A,I3,2X,3I3)')
12687 & ' direct photon processes',(IPRON(8,K),K=1,4)
12688
12689C calculate effective cross section
12690 SIGGEN(4) = 0.D0
12691 DO 165 I=1,IEEMAX
12692 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12693 & PVIRT(1),PVIRT(2))
12694 SIGMAX = 0.D0
12695 if(iswmdl(2).ge.1) then
12696 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12697 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12698 & -SIGLDD-SIGHDD-SIGDIR
12699 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12700 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12701 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12702 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12703 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12704 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12705 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12706 else
12707 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12708 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12709 endif
12710 IF(SIGMAX.GT.SIGGEN(4)) THEN
12711 ISIGM = I
12712 SIGGEN(4) = SIGMAX
12713 ENDIF
12714 165 CONTINUE
12715 ENDIF
12716
12717C debug output
12718 IF(SIGGEN(4).LT.1.D-20) THEN
12719 WRITE(LO,'(//1X,A)')
12720 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12721 STOP
12722 ENDIF
12723 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12724 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12725 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12726
12727 END
12728
12729*$ CREATE PHO_REJSTA.FOR
12730*COPY PHO_REJSTA
12731CDECK ID>, PHO_REJSTA
12732 SUBROUTINE PHO_REJSTA(IMODE)
12733C********************************************************************
12734C
12735C MC rejection counting
12736C
12737C input IMODE -1 initialization
12738C -2 output of statistics
12739C
12740C********************************************************************
12741 IMPLICIT NONE
12742 SAVE
12743
12744C input/output channels
12745 INTEGER LI,LO
12746 COMMON /POINOU/ LI,LO
12747C event debugging information
12748 INTEGER NMAXD
12749 PARAMETER (NMAXD=100)
12750 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12751 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12752 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12753 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12754C internal rejection counters
12755 INTEGER NMXJ
12756 PARAMETER (NMXJ=60)
12757 CHARACTER*10 REJTIT
12758 INTEGER IFAIL
12759 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12760
12761 INTEGER IMODE
12762
12763 INTEGER I
12764
12765C initialization
12766 IF(IMODE.EQ.-1) THEN
12767 DO 100 I=1,NMXJ
12768 IFAIL(I) = 0
12769 100 CONTINUE
12770C
12771 REJTIT(1) = 'PARTON ALL'
12772 REJTIT(2) = 'STDPAR ALL'
12773 REJTIT(3) = 'STDPAR DPO'
12774 REJTIT(4) = 'POMSCA ALL'
12775 REJTIT(5) = 'POMSCA INT'
12776 REJTIT(6) = 'POMSCA KIN'
12777 REJTIT(7) = 'DIFDIS ALL'
12778 REJTIT(8) = 'POSPOM ALL'
12779 REJTIT(9) = 'HRES.DIF.1'
12780 REJTIT(10) = 'HDIR.DIF.1'
12781 REJTIT(11) = 'HRES.DIF.2'
12782 REJTIT(12) = 'HDIR.DIF.2'
12783 REJTIT(13) = 'DIFDIS INT'
12784 REJTIT(14) = 'HADRON SP2'
12785 REJTIT(15) = 'HADRON SP3'
12786 REJTIT(16) = 'HARDIR ALL'
12787 REJTIT(17) = 'HARDIR INT'
12788 REJTIT(18) = 'HARDIR KIN'
12789 REJTIT(19) = 'MCHECK BAR'
12790 REJTIT(20) = 'MCHECK MES'
12791 REJTIT(21) = 'DIF.DISS.1'
12792 REJTIT(22) = 'DIF.DISS.2'
12793 REJTIT(23) = 'STRFRA ALL'
12794 REJTIT(24) = 'MSHELL CHA'
12795 REJTIT(25) = 'PARTPT SOF'
12796 REJTIT(26) = 'PARTPT HAR'
12797 REJTIT(27) = 'INTRINS KT'
12798 REJTIT(28) = 'HACHEK DIR'
12799 REJTIT(29) = 'HACHEK RES'
12800 REJTIT(30) = 'STRING ALL'
12801 REJTIT(31) = 'POMSCA INT'
12802 REJTIT(32) = 'DIFF SLOPE'
12803 REJTIT(33) = 'GLU2QU ALL'
12804 REJTIT(34) = 'MASCOR ALL'
12805 REJTIT(35) = 'PARCOR ALL'
12806 REJTIT(36) = 'MSHELL PAR'
12807 REJTIT(37) = 'MSHELL ALL'
12808 REJTIT(38) = 'POMCOR ALL'
12809 REJTIT(39) = 'DB-POM KIN'
12810 REJTIT(40) = 'DB-POM ALL'
12811 REJTIT(41) = 'SOFTXX ALL'
12812 REJTIT(42) = 'SOFTXX PSP'
12813
12814C write output
12815 ELSE IF(IMODE.EQ.-2) THEN
12816 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12817 & '--------------------------------'
12818 DO 300 I=1,NMXJ
12819 IF(IFAIL(I).GT.0)
12820 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12821 300 CONTINUE
12822 ELSE
12823 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12824 ENDIF
12825
12826 END
12827
12828*$ CREATE PHO_POSPOM.FOR
12829*COPY PHO_POSPOM
12830CDECK ID>, PHO_POSPOM
12831 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12832C***********************************************************************
12833C
12834C registration of one cut pomeron (soft/semihard)
12835C
12836C input: IP particle combination the pomeron belongs to
12837C IND1,2 position of X values in /POSOFT/
12838C 1 corresponds to a valence-pomeron
12839C IGEN production process of mother particles
12840C IPOM pomeron number
12841C KCUT total number of cut pomerons and reggeons
12842C
12843C output: ISWAP exchange of x values
12844C IND1,2 increased by the number of partons belonging
12845C to the generated pomeron cut
12846C IREJ success/failure
12847C
12848C**********************************************************************
12849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12850 SAVE
12851
12852 PARAMETER ( DEPS = 1.D-8 )
12853
12854C input/output channels
12855 INTEGER LI,LO
12856 COMMON /POINOU/ LI,LO
12857C event debugging information
12858 INTEGER NMAXD
12859 PARAMETER (NMAXD=100)
12860 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12861 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12862 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12863 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12864C internal rejection counters
12865 INTEGER NMXJ
12866 PARAMETER (NMXJ=60)
12867 CHARACTER*10 REJTIT
12868 INTEGER IFAIL
12869 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12870C model switches and parameters
12871 CHARACTER*8 MDLNA
12872 INTEGER ISWMDL,IPAMDL
12873 DOUBLE PRECISION PARMDL
12874 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12875C general process information
12876 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12877 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12878C global event kinematics and particle IDs
12879 INTEGER IFPAP,IFPAB
12880 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12881 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12882C data of c.m. system of Pomeron / Reggeon exchange
12883 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12884 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12885 & SIDP,CODP,SIFP,COFP
12886 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12887 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12888 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12889C obsolete cut-off information
12890 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12891 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12892C energy-interpolation table
12893 INTEGER IEETA2
12894 PARAMETER ( IEETA2 = 20 )
12895 INTEGER ISIMAX
12896 DOUBLE PRECISION SIGTAB,SIGECM
12897 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12898C light-cone x fractions and c.m. momenta of soft cut string ends
12899 INTEGER MAXSOF
12900 PARAMETER ( MAXSOF = 50 )
12901 INTEGER IJSI2,IJSI1
12902 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12903 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12904 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12905 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12906C standard particle data interface
12907 INTEGER NMXHEP
12908 PARAMETER (NMXHEP=4000)
12909 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12910 DOUBLE PRECISION PHEP,VHEP
12911 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12912 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12913 & VHEP(4,NMXHEP)
12914C extension to standard particle data interface (PHOJET specific)
12915 INTEGER IMPART,IPHIST,ICOLOR
12916 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12917C table of particle indices for recursive PHOJET calls
12918 INTEGER MAXIPX
12919 PARAMETER ( MAXIPX = 100 )
12920 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12921 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12922 & IPOIX1,IPOIX2,IPOIX3
12923
12924 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12925
12926 IREJ = 0
12927 ISWAP = 0
12928 JM1 = NPOSP(1)
12929 JM2 = NPOSP(2)
12930 INDX1 = IND1
12931 INDX2 = IND2
12932 EA1 = XS1(IND1)*ECMP/2.D0
12933 EA2 = XS1(IND1+1)*ECMP/2.D0
12934 EB1 = XS2(IND2)*ECMP/2.D0
12935 EB2 = XS2(IND2+1)*ECMP/2.D0
12936 CMASS1 = MIN(EA1,EA2)
12937 CMASS2 = MIN(EB1,EB2)
12938
12939C debug output
12940 IF(IDEB(9).GE.20) THEN
12941 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12942 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12943 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12944 & CMASS1,CMASS2
12945 ENDIF
12946
12947C flavours
12948 IF(IND1.EQ.1) THEN
12949 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12950 ELSE
12951 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12952 ENDIF
12953 IF(IND2.EQ.1) THEN
12954 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12955 ELSE
12956 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12957 ENDIF
12958 DO 75 I=1,4
12959 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12960 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12961 75 CONTINUE
12962
12963C pomeron resolved?
12964 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12965C find energy for cross section calculation
12966 IF(IPAMDL(16).EQ.2) THEN
12967 ESUB = ECMP
12968 ELSE IF(IPAMDL(16).EQ.3) THEN
12969 IF(IPROCE.EQ.1) THEN
12970 ESUB = ECM
12971 ELSE
12972 ESUB = ECMP
12973 ENDIF
12974 ELSE
12975 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12976 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
12977 ENDIF
12978C load cross sections from interpolation table
12979 IF(ESUB.LE.SIGECM(IP,1)) THEN
12980 I1 = 1
12981 I2 = 2
12982 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
12983 DO 50 I=2,ISIMAX
12984 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
12985 50 CONTINUE
12986 200 CONTINUE
12987 I1 = I-1
12988 I2 = I
12989 ELSE
12990 WRITE(LO,'(/1X,A,2E12.3)')
12991 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
12992 CALL PHO_PREVNT(-1)
12993 I1 = ISIMAX-1
12994 I2 = ISIMAX
12995 ENDIF
12996 FAC2=0.D0
12997 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
12998 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12999 FAC1=1.D0-FAC2
13000C calculate weights
13001* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13002* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13003* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13004* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13005* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13006* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13007
13008 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13009 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13010 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13011 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13012 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13013 & +SIGTAB(IP,64,I2))
13014 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13015 & +SIGTAB(IP,64,I1))
13016 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13017 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13018 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13019 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13020
13021C one-pomeron cut
13022 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13023C central diff. cut
13024 WGX(2) = WGXCDF
13025C diff. diss. of particle 1
13026 WGX(3) = WGXHSD(1)
13027C diff. diss. of particle 2
13028 WGX(4) = WGXHSD(2)
13029C double diff. dissociation
13030 WGX(5) = WGXHDD
13031C two-pomeron cut
13032 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13033
13034* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13035* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13036* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13037* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13038* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13039* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13040* ENDIF
13041
13042 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13043
13044C selection loop
13045 205 CONTINUE
13046 XI = DT_RNDM(SUM)*SUM
13047 I = 0
13048 SUM = 0.D0
13049 210 CONTINUE
13050 I = I+1
13051 SUM = SUM+WGX(I)
13052 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13053C phase space correction
13054 IF(I.NE.1) THEN
13055 ISAM = 4
13056 IF(I.EQ.6) ISAM = 8
13057 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13058* IF(DT_RNDM(SUM).GT.PACC) I=1
13059 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13060 ENDIF
13061
13062C do not generate diffraction for events with only one cut pomeron
13063 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13064
13065C do not generate recursive calls for remants with
13066C diquark-anti-diquark flavour contents
13067 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13068 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13069
13070C debug output
13071 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13072 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13073
13074 IF(I.GT.1) THEN
13075C second scattering needed
13076 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13077 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13078 IDPD1 = IPHO_ID2PDG(IDHA1)
13079 IDPD2 = IPHO_ID2PDG(IDHA2)
13080
13081 if(INDX1.eq.1) then
13082 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13083 & IGEN_had = IGEN
13084 else
13085 IGEN_had = -IGEN
13086 endif
13087 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13088 & IPOM,IGEN_had,0,0,IPOS1,1)
13089
13090 if(INDX2.eq.1) then
13091 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13092 & IGEN_had = IGEN
13093 else
13094 IGEN_had = -IGEN
13095 endif
13096 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13097 & IPOM,IGEN_had,0,0,IPOS1,1)
13098
13099 IND1 = IND1+2
13100 IND2 = IND2+2
13101C update index
13102 IPOIX2 = IPOIX2+1
13103 IF(IPOIX2.GT.MAXIPX) THEN
13104 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13105 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13106 IREJ = 1
13107 RETURN
13108 ENDIF
13109 IPORES(IPOIX2) = I+2
13110 IPOPOS(1,IPOIX2) = IPOS1-1
13111 IPOPOS(2,IPOIX2) = IPOS1
13112 RETURN
13113 ENDIF
13114 ENDIF
13115
13116 100 CONTINUE
13117 IF(ISWMDL(12).EQ.0) THEN
13118C sample colors
13119 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13120 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13121
13122C purely gluonic pomeron or sea strings formed by gluons
13123
13124 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13125 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13126 IFLA1 = 21
13127 IFLA2 = 21
13128 ENDIF
13129 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13130 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13131 IFLB1 = 21
13132 IFLB2 = 21
13133 ENDIF
13134
13135C color connection
13136 IF(IFLA1.NE.21) THEN
13137 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13138 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13139 & CALL PHO_SWAPI(ICA1,ICD1)
13140 ENDIF
13141 IF(IFLB1.NE.21) THEN
13142 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13143 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13144 & CALL PHO_SWAPI(ICB1,ICC1)
13145 ENDIF
13146 ISWAP = 0
13147 IF(ICA1*ICB1.GT.0) THEN
13148 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13149 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13150 CALL PHO_SWAPI(IFLA1,IFLA2)
13151 CALL PHO_SWAPI(ICA1,ICD1)
13152 ELSE
13153 CALL PHO_SWAPI(IFLB1,IFLB2)
13154 CALL PHO_SWAPI(ICB1,ICC1)
13155 ENDIF
13156 ELSE IF(IND1.NE.1) THEN
13157 CALL PHO_SWAPI(IFLA1,IFLA2)
13158 CALL PHO_SWAPI(ICA1,ICD1)
13159 ELSE IF(IND2.NE.1) THEN
13160 CALL PHO_SWAPI(IFLB1,IFLB2)
13161 CALL PHO_SWAPI(ICB1,ICC1)
13162 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13163 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13164 CALL PHO_SWAPI(IFLA1,IFLA2)
13165 CALL PHO_SWAPI(ICA1,ICD1)
13166 ELSE
13167 CALL PHO_SWAPI(IFLB1,IFLB2)
13168 CALL PHO_SWAPI(ICB1,ICC1)
13169 ENDIF
13170 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13171 CALL PHO_SWAPI(IFLA1,IFLA2)
13172 CALL PHO_SWAPI(ICA1,ICD1)
13173 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13174 CALL PHO_SWAPI(IFLB1,IFLB2)
13175 CALL PHO_SWAPI(ICB1,ICC1)
13176 ELSE
13177 ISWAP = 1
13178 IF(IDEB(9).GE.5) THEN
13179 WRITE(LO,'(1X,A,I12)')
13180 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13181 WRITE(LO,'(5X,A,4I7)')
13182 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13183 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13184 ENDIF
13185 ENDIF
13186 ENDIF
13187
13188C registration
13189
13190C purely gluonic pomeron or sea strings formed by gluons
13191 IF(IFLA1.EQ.21) THEN
13192 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13193 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13194 IND1 = IND1+2
13195
13196C strings formed by quarks
13197 ELSE
13198C valence quark labels
13199 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13200 & .and.(IDHEP(JM1).NE.990)) THEN
13201 ICA2 = 1
13202 ICD2 = 1
13203 ENDIF
13204C registration
13205 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13206 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13207 & ICA2,IPOS1,1)
13208 IND1 = IND1+1
13209 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13210 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13211 & ICD2,IPOS,1)
13212 IND1 = IND1+1
13213 ENDIF
13214
13215C purely gluonic pomeron or sea strings formed by gluons
13216 IF(IFLB1.EQ.21) THEN
13217 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13218 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13219 IND2 = IND2+2
13220
13221C strings formed by quarks
13222 ELSE
13223C valence quark labels
13224 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13225 & .and.(IDHEP(JM2).NE.990)) THEN
13226 ICB2 = 1
13227 ICC2 = 1
13228 ENDIF
13229C registration
13230 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13231 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13232 & ICB2,IPOS,1)
13233 IND2 = IND2+1
13234 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13235 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13236 & ICC2,IPOS2,1)
13237 IND2 = IND2+1
13238 ENDIF
13239
13240C soft pt assignment
13241 IF(ISWMDL(18).EQ.0) THEN
13242 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13243 IF(IREJ.NE.0) THEN
13244 IFAIL(25) = IFAIL(25)+1
13245 RETURN
13246 ENDIF
13247 ENDIF
13248 ELSE
13249* CALL PHO_BFKL(P1,P2,IPART,IREJ)
13250* IF(IREJ.NE.0) RETURN
13251 ENDIF
13252
13253 END
13254
13255*$ CREATE PHO_HADSP2.FOR
13256*COPY PHO_HADSP2
13257CDECK ID>, PHO_HADSP2
13258 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13259C***********************************************************************
13260C
13261C split hadron momentum XMAX into two partons using
13262C lower cut-off: AS
13263C
13264C input: IFLB compressed particle code of particle to split
13265C XS1 sum of x values already selected
13266C XMAX maximal x possible
13267C
13268C output: XS1 new sum of x values (without first one)
13269C XSOFT1 field of selected x values
13270C
13271C**********************************************************************
13272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13273 SAVE
13274
13275 PARAMETER ( DEPS = 1.D-8 )
13276
13277 DIMENSION XSOFT1(50)
13278
13279C input/output channels
13280 INTEGER LI,LO
13281 COMMON /POINOU/ LI,LO
13282C event debugging information
13283 INTEGER NMAXD
13284 PARAMETER (NMAXD=100)
13285 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13286 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13287 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13288 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13289C internal rejection counters
13290 INTEGER NMXJ
13291 PARAMETER (NMXJ=60)
13292 CHARACTER*10 REJTIT
13293 INTEGER IFAIL
13294 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13295C data on most recent hard scattering
13296 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13297 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13298 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13299 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13300 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13301 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13302 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13303 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13304 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13305
13306C model exponents
13307 DATA PVMES1 /-0.5D0/
13308 DATA PVMES2 /-0.5D0/
13309 DATA PVBAR1 / 1.5D0/
13310 DATA PVBAR2 /-0.5D0/
13311C
13312 IREJ = 0
13313 ITMAX = 100
13314C
13315C mesonic particle
13316 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13317 XPOT1 = PVMES1+1.D0
13318 XPOT2 = PVMES2+1.D0
13319C baryonic particle
13320 ELSE
13321 XPOT1 = PVBAR1+1.D0
13322 XPOT2 = PVBAR2+1.D0
13323 ENDIF
13324 ITER = 0
13325 XREST= 1.D0-XS1
13326C selection loop
13327 100 CONTINUE
13328 ITER = ITER+1
13329 IF(ITER.GE.ITMAX) THEN
13330 IF(IDEB(39).GE.3) THEN
13331 WRITE(LO,'(1X,A,I8)')
13332 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13333 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13334 ENDIF
13335 IFAIL(14) = IFAIL(14)+1
13336 IREJ = 1
13337 RETURN
13338 ENDIF
13339 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13340 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13341 XSS1 = XS1 + ZZ
13342 IF((1.D0-XSS1).LT.AS) GOTO 100
13343C
13344 XS1 = XSS1
13345 XSOFT1(1) = 1.D0-XSS1
13346 XSOFT1(2) = ZZ
13347C debug output
13348 IF(IDEB(39).GE.10) THEN
13349 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13350 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13351 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13352 ENDIF
13353 END
13354
13355*$ CREATE PHO_HADSP3.FOR
13356*COPY PHO_HADSP3
13357CDECK ID>, PHO_HADSP3
13358 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13359C***********************************************************************
13360C
13361C split hadron momentum XMAX into diquark & quark pair
13362C using lower cut-off: AS
13363C
13364C input: IFLB compressed particle code of particle to split
13365C XS1 sum of x values already selected
13366C XMAX maximal x possible
13367C
13368C output: XS1 new sum of x values
13369C XSOFT1 field of selected x values
13370C
13371C
13372C**********************************************************************
13373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13374 SAVE
13375 PARAMETER ( DEPS = 1.D-8 )
13376
13377 DIMENSION XSOFT1(50),XSOFT2(50)
13378
13379C input/output channels
13380 INTEGER LI,LO
13381 COMMON /POINOU/ LI,LO
13382C event debugging information
13383 INTEGER NMAXD
13384 PARAMETER (NMAXD=100)
13385 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13386 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13387 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13388 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13389C internal rejection counters
13390 INTEGER NMXJ
13391 PARAMETER (NMXJ=60)
13392 CHARACTER*10 REJTIT
13393 INTEGER IFAIL
13394 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13395C data of c.m. system of Pomeron / Reggeon exchange
13396 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13397 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13398 & SIDP,CODP,SIFP,COFP
13399 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13400 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13401 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13402
13403 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13404
13405C model exponents
13406 DATA PVMES1 /-0.5D0/
13407 DATA PVMES2 /-0.5D0/
13408 DATA PSMES /-0.99D0/
13409 DATA PVBAR1 / 1.5D0/
13410 DATA PVBAR2 /-0.5D0/
13411 DATA PSBAR /-0.99D0/
13412C
13413 IREJ = 0
13414C
13415C determine exponents
13416C particle 1
13417C
13418 XMMIN = 0.3D0/ECMP
13419 XBMIN = 1.6D0/ECMP
13420C mesonic particle
13421 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13422 XPOT1(1) = PVMES1
13423 XMIN(1,1) = XMMIN
13424 XPOT1(2) = PVMES2
13425 XMIN(1,2) = XMMIN
13426 XPOT1(3) = PSMES
13427 XMIN(1,3) = XMMIN
13428C baryonic particle
13429 ELSE
13430 XPOT1(1) = PVBAR1
13431 XMIN(1,1) = XBMIN
13432 XPOT1(2) = PVBAR2
13433 XMIN(1,2) = XMMIN
13434 XPOT1(3) = PSBAR
13435 XMIN(1,3) = XMMIN
13436 ENDIF
13437C particle 2
13438C mesonic particle
13439 XPOT2(1) = PVMES1
13440 XMIN(2,1) = XMMIN
13441 XPOT2(2) = PVMES2
13442 XMIN(2,2) = XMMIN
13443 XPOT2(3) = PSMES
13444 XMIN(2,3) = XMMIN
13445C
13446 XDUM1 = 0.01D0
13447 XDUM2 = 0.99D0
13448 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13449 & XSOFT1,XSOFT2,IREJ)
13450C rejection?
13451 IF(IREJ.NE.0) THEN
13452 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13453 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13454 IFAIL(15) = IFAIL(15)+1
13455 IREJ = 1
13456 RETURN
13457 ENDIF
13458C debug output
13459 IF(IDEB(74).GE.10) THEN
13460 WRITE(LO,'(1X,A,I6,2E12.4)')
13461 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13462 DO 100 I=1,3
13463 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13464 100 CONTINUE
13465 ENDIF
13466
13467 END
13468
13469*$ CREATE PHO_SOFTXX.FOR
13470*COPY PHO_SOFTXX
13471CDECK ID>, PHO_SOFTXX
13472 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13473 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13474C***********************************************************************
13475C
13476C select soft x values
13477C
13478C input: JM1,JM2 mother particle index in POEVT1
13479C (0 flavour not known before)
13480C MSPAR1,2 number of x values to select
13481C IVAL1,2 number valence quarks involved in hard
13482C scattering (0,1,2)
13483C MSM1,2 minimum number of soft x to get sampled
13484C XSUM1,2 sum of all x values samples up this call
13485C XMAX1,2 max. x value
13486C
13487C output XSUM1,2 new sum of x-values sampled
13488C XS1,2 field containing sampled x values
13489C
13490C x values of valence partons are first given
13491C
13492C***********************************************************************
13493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13494 SAVE
13495
13496C input/output channels
13497 INTEGER LI,LO
13498 COMMON /POINOU/ LI,LO
13499C event debugging information
13500 INTEGER NMAXD
13501 PARAMETER (NMAXD=100)
13502 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13503 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13504 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13505 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13506C internal rejection counters
13507 INTEGER NMXJ
13508 PARAMETER (NMXJ=60)
13509 CHARACTER*10 REJTIT
13510 INTEGER IFAIL
13511 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13512C model switches and parameters
13513 CHARACTER*8 MDLNA
13514 INTEGER ISWMDL,IPAMDL
13515 DOUBLE PRECISION PARMDL
13516 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13517C data of c.m. system of Pomeron / Reggeon exchange
13518 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13519 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13520 & SIDP,CODP,SIFP,COFP
13521 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13522 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13523 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13524C standard particle data interface
13525 INTEGER NMXHEP
13526 PARAMETER (NMXHEP=4000)
13527 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13528 DOUBLE PRECISION PHEP,VHEP
13529 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13530 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13531 & VHEP(4,NMXHEP)
13532C extension to standard particle data interface (PHOJET specific)
13533 INTEGER IMPART,IPHIST,ICOLOR
13534 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13535C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13536 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13537 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13538 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13539 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13540C obsolete cut-off information
13541 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13542 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13543C data on most recent hard scattering
13544 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13545 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13546 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13547 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13548 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13549 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13550 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13551 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13552 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13553
13554 DIMENSION XS1(*),XS2(*)
13555
13556 INTEGER MAXPOT
13557 PARAMETER ( MAXPOT = 50 )
13558 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13559
13560 IREJ = 0
13561
13562 MSMAX = MAX(MSPAR1,MSPAR2)
13563 MSMIN = MAX(MSM1,MSM2)
13564 IF(MSMAX.GT.MAXPOT) THEN
13565 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13566 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13567 IREJ = 1
13568 RETURN
13569 ENDIF
13570C determine exponents
13571 IBAR1 = ipho_bar3(JM1,2)
13572 IBAR2 = ipho_bar3(JM2,2)
13573 ISWAP = 0
13574 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13575C meson-baryon scattering (asymmetric sea)
13576 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13577 PSBAR = PARMDL(53)
13578 PSMES = PARMDL(57)
13579 ELSE
13580 PSBAR = PARMDL(52)
13581 PSMES = PARMDL(56)
13582 ENDIF
13583
13584C lower limits for x sampling
13585 XMMINA = 2.D0*PARMDL(157)/ECMP
13586 XBMINA = 2.D0*PARMDL(158)/ECMP
13587 XSMINA = 2.D0*PARMDL(159)/ECMP
13588 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13589 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13590 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13591 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13592 XMIN1 = MAX(AS/XMAX2,XMIN1)
13593 XMIN2 = MAX(AS/XMAX1,XMIN2)
13594
13595C particle 1
13596 XMMIN1 = MAX(XMIN1,XMMINA)
13597 XBMIN1 = MAX(XMIN1,XBMINA)
13598 XSMIN1 = MAX(XMIN1,XSMINA)
13599C mesonic particle
13600 IF(IBAR1.EQ.0) THEN
13601 IF(IHFLS(1).EQ.0) THEN
13602 XPOT1(1) = PARMDL(62)
13603 XMIN(1,1) = XSMIN1
13604 XPOT1(2) = PARMDL(63)
13605 XMIN(1,2) = XSMIN1
13606 ELSE
13607 XPOT1(1) = PARMDL(54)
13608 XMIN(1,1) = XMMIN1
13609 XPOT1(2) = PARMDL(55)
13610 XMIN(1,2) = XMMIN1
13611 ENDIF
13612 DO 100 I=3-IVAL1,MSMAX
13613 XPOT1(I) = PSMES
13614 XMIN(1,I) = XSMIN1
13615 100 CONTINUE
13616C baryonic particle
13617 ELSE
13618 IF(IHFLS(1).EQ.0) THEN
13619 XPOT1(1) = PARMDL(62)
13620 XMIN(1,1) = XSMIN1
13621 XPOT1(2) = PARMDL(63)
13622 XMIN(1,2) = XSMIN1
13623 ELSE
13624 XPOT1(1) = PARMDL(50)
13625 XMIN(1,1) = XBMIN1
13626 XPOT1(2) = PARMDL(51)
13627 XMIN(1,2) = XMMIN1
13628 ENDIF
13629 DO 200 I=3-IVAL1,MSMAX
13630 XPOT1(I) = PSBAR
13631 XMIN(1,I) = XSMIN1
13632 200 CONTINUE
13633 ENDIF
13634
13635C particle 2
13636 XMMIN2 = MAX(XMIN2,XMMINA)
13637 XBMIN2 = MAX(XMIN2,XBMINA)
13638 XSMIN2 = MAX(XMIN2,XSMINA)
13639C mesonic particle
13640 IF(IBAR2.EQ.0) THEN
13641 IF(IHFLS(2).EQ.0) THEN
13642 XPOT2(1) = PARMDL(62)
13643 XMIN(2,1) = XSMIN2
13644 XPOT2(2) = PARMDL(63)
13645 XMIN(2,2) = XSMIN2
13646 ELSE
13647 XPOT2(1) = PARMDL(54)
13648 XMIN(2,1) = XMMIN2
13649 XPOT2(2) = PARMDL(55)
13650 XMIN(2,2) = XMMIN2
13651 ENDIF
13652 DO 300 I=3-IVAL2,MSMAX
13653 XPOT2(I) = PSMES
13654 XMIN(2,I) = XSMIN2
13655 300 CONTINUE
13656C baryonic particle
13657 ELSE
13658 IF(IHFLS(2).EQ.0) THEN
13659 XPOT2(1) = PARMDL(62)
13660 XMIN(2,1) = XSMIN2
13661 XPOT2(2) = PARMDL(63)
13662 XMIN(2,2) = XSMIN2
13663 ELSE
13664 XPOT2(1) = PARMDL(50)
13665 XMIN(2,1) = XBMIN2
13666 XPOT2(2) = PARMDL(51)
13667 XMIN(2,2) = XMMIN2
13668 ENDIF
13669 DO 400 I=3-IVAL2,MSMAX
13670 XPOT2(I) = PSBAR
13671 XMIN(2,I) = XSMIN2
13672 400 CONTINUE
13673 ENDIF
13674
13675 XSS1 = XSUM1
13676 XSS2 = XSUM2
13677 MSOFT = MSMAX
13678
13679C check limits (important for valences)
13680 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13681 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13682
13683 XMINS1 = XSS1
13684 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13685 XMINS2 = XSS2
13686 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13687 DO 10 I=1,MSOFT
13688 XMINS1 = XMINS1+XMIN(1,I)
13689 XMINS2 = XMINS2+XMIN(2,I)
13690 10 CONTINUE
13691 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13692
13693C try to sample x values
13694 IF(IPAMDL(14).EQ.0) THEN
13695 IF(MSOFT.EQ.2) THEN
13696 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13697 & XS1,XS2,IREJ)
13698 ELSE IF(MSOFT.LT.5) THEN
13699 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13700 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13701 ELSE
13702 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13703 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13704 ENDIF
13705 ELSE IF(IPAMDL(14).EQ.1) THEN
13706 IF(MSOFT.EQ.2) THEN
13707 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13708 & XS1,XS2,IREJ)
13709 ELSE
13710 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13711 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13712 ENDIF
13713 ELSE IF(IPAMDL(14).EQ.2) THEN
13714 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13715 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13716 ELSE IF(IPAMDL(14).EQ.3) THEN
13717 IF(MSOFT.EQ.2) THEN
13718 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13719 & XS1,XS2,IREJ)
13720 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13721 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13722 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13723 ELSE
13724 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13725 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13726 ENDIF
13727 ELSE
13728 WRITE(LO,'(/,1X,A,I3)')
13729 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13730 STOP
13731 ENDIF
13732 IF(IREJ.NE.0) THEN
13733 IFAIL(41) = IFAIL(41)+1
13734 IF(IDEB(60).GE.2) THEN
13735 WRITE(LO,'(1X,A,I12,4I3)')
13736 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13737 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13738 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13739 & XSUM1,XSUM2,XMAX1,XMAX2
13740 ENDIF
13741 RETURN
13742 ENDIF
13743 IF(MSOFT.NE.MSMAX) THEN
13744 MSDIFF = MSMAX-MSOFT
13745 MSPAR1 = MSPAR1-MSDIFF
13746 MSPAR2 = MSPAR2-MSDIFF
13747 ENDIF
13748
13749C correct for different MSPAR numbers
13750 IF(MSOFT.NE.MSPAR1) THEN
13751 IF(MSPAR1.GT.1) THEN
13752 XDEL = 0.D0
13753 DO 500 I=MSPAR1+1,MSOFT
13754 XDEL = XDEL+XS1(I)
13755 500 CONTINUE
13756 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13757 DO 550 I=2,MSPAR1
13758 XS1(I) = XS1(I)*XFAC
13759 550 CONTINUE
13760 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13761 ELSE
13762 XSS1 = XSUM1
13763 ENDIF
13764 ENDIF
13765 IF(MSOFT.NE.MSPAR2) THEN
13766 IF(MSPAR2.GT.1) THEN
13767 XDEL = 0.D0
13768 DO 600 I=MSPAR2+1,MSOFT
13769 XDEL = XDEL+XS2(I)
13770 600 CONTINUE
13771 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13772 DO 650 I=2,MSPAR2
13773 XS2(I) = XS2(I)*XFAC
13774 650 CONTINUE
13775 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13776 ELSE
13777 XSS2 = XSUM2
13778 ENDIF
13779 ENDIF
13780
13781C first x entry
13782 XS1(1) = 1.D0 - XSS1
13783 XS2(1) = 1.D0 - XSS2
13784 XSUM1 = XSS1
13785 XSUM2 = XSS2
13786
13787C debug output
13788 IF(IDEB(60).GE.10) THEN
13789 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13790 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13791 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13792 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13793 DO 30 I=1,MSOFT
13794 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13795 & XMIN(1,I),XMIN(2,I)
13796 30 CONTINUE
13797 ENDIF
13798
13799 RETURN
13800
13801C not enough phase space
13802 1000 CONTINUE
13803
13804 IFAIL(42) = IFAIL(42)+1
13805 IREJ = 1
13806
13807C warning message
13808 IF(IDEB(60).GE.1) THEN
13809 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13810 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13811 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13812 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13813 WRITE(LO,'(1X,A,1P,3E11.3)')
13814 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13815 WRITE(LO,'(1X,A,1P,3E11.3)')
13816 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13817 WRITE(LO,'(1X,A,1P,3E11.3)')
13818 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13819 WRITE(LO,'(1X,A)')
13820 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13821 DO 27 I=1,MSOFT
13822 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13823 27 CONTINUE
13824 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13825 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13826 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13827 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13828 DO 25 I=1,MSOFT
13829 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13830 & XMIN(1,I),XMIN(2,I)
13831 25 CONTINUE
13832 ENDIF
13833
13834 END
13835
13836*$ CREATE PHO_SELSXR.FOR
13837*COPY PHO_SELSXR
13838CDECK ID>, PHO_SELSXR
13839 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13840 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13841C***********************************************************************
13842C
13843C select x values of soft string ends (rejection method)
13844C
13845C***********************************************************************
13846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13847 SAVE
13848
13849 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13850
13851C input/output channels
13852 INTEGER LI,LO
13853 COMMON /POINOU/ LI,LO
13854C event debugging information
13855 INTEGER NMAXD
13856 PARAMETER (NMAXD=100)
13857 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13858 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13859 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13860 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13861C model switches and parameters
13862 CHARACTER*8 MDLNA
13863 INTEGER ISWMDL,IPAMDL
13864 DOUBLE PRECISION PARMDL
13865 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13866C data on most recent hard scattering
13867 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13868 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13869 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13870 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13871 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13872 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13873 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13874 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13875 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13876C global event kinematics and particle IDs
13877 INTEGER IFPAP,IFPAB
13878 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13879 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13880C obsolete cut-off information
13881 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13882 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13883
13884 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13885
13886 IF(IDEB(13).GE.10) THEN
13887 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13888 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13889 & MSOFT,XS1,XS2,XMAX1,XMAX2
13890 DO 40 I=1,MSOFT
13891 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13892 40 CONTINUE
13893 ENDIF
13894C
13895 IREJ = 0
13896C
13897 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13898 XMIN1 = MAX(AS/XMAX1,XMINK)
13899 XMIN2 = MAX(AS/XMAX2,XMINK)
13900C
13901 IF(MSOFT.EQ.1) THEN
13902 XSOFT1(2) = 0.D0
13903 XSOFT2(2) = 0.D0
13904 RETURN
13905 ENDIF
13906 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13907 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13908C
13909 10 CONTINUE
13910C
13911 DO 50 I=2,MSOFT
13912 POT(1,I) = XPOT1(I)+1.D0
13913 POT(2,I) = XPOT2(I)+1.D0
13914 REVP(1,I) = 1.D0/POT(1,I)
13915 REVP(2,I) = 1.D0/POT(2,I)
13916 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13917 XLMAX = XMAX1**POT(1,I)
13918 XLDIF(1,I) = XLMAX-XLMIN(1,I)
13919 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13920 XLMAX = XMAX2**POT(2,I)
13921 XLDIF(2,I) = XLMAX-XLMIN(2,I)
13922 50 CONTINUE
13923C
13924 ITRY0 = 0
13925 5 CONTINUE
13926 ITRY0 = ITRY0 + 1
13927 IF(ITRY0.GE.IPAMDL(181)) THEN
13928 IF(MSOFT-MSMIN.GE.2) THEN
13929 MSOFT = MSMIN
13930 GOTO 10
13931 ENDIF
13932 GOTO 1000
13933 ENDIF
13934 XREST1 = 1.D0-XS1
13935 XREST2 = 1.D0-XS2
13936 DO 100 I=2,MSOFT
13937 ITRY1 = 0
13938
13939 20 CONTINUE
13940 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13941 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13942 XSOFT1(I) = Z1**REVP(1,I)
13943 XSOFT2(I) = Z2**REVP(2,I)
13944 ITRY1 = ITRY1+1
13945 IF(ITRY1.GE.50) GOTO 1000
13946 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13947
13948 XREST1 = XREST1-XSOFT1(I)
13949 IF(XREST1.LT.XMIN1) GOTO 5
13950 IF(XREST1.LT.XMIN(1,1)) GOTO 5
13951 XREST2 = XREST2-XSOFT2(I)
13952 IF(XREST2.LT.XMIN2) GOTO 5
13953 IF(XREST2.LT.XMIN(2,1)) GOTO 5
13954 IF(XREST1*XREST2.LT.AS) GOTO 5
13955
13956 100 CONTINUE
13957 XSOFT1(1) = XREST1
13958 XSOFT2(1) = XREST2
13959 IREJ=0
13960* XX = 1.D0
13961* DO 200 I=2,MSOFT
13962* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13963*200 CONTINUE
13964 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13965 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13966
13967 XS1 = 1.D0-XREST1
13968 XS2 = 1.D0-XREST2
13969 RETURN
13970
13971 1000 CONTINUE
13972 IREJ = 1
13973 IF(IDEB(13).GE.2) THEN
13974 WRITE(LO,'(1X,A,2I4)')
13975 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13976 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
13977 ENDIF
13978
13979 END
13980
13981*$ CREATE PHO_SELSX2.FOR
13982*COPY PHO_SELSX2
13983CDECK ID>, PHO_SELSX2
13984 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
13985 & XS1,XS2,IREJ)
13986C***********************************************************************
13987C
13988C select x values of soft string ends using PHO_RNDBET
13989C
13990C***********************************************************************
13991 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13992 SAVE
13993
13994 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
13995
13996C input/output channels
13997 INTEGER LI,LO
13998 COMMON /POINOU/ LI,LO
13999C event debugging information
14000 INTEGER NMAXD
14001 PARAMETER (NMAXD=100)
14002 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14003 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14004 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14005 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14006C model switches and parameters
14007 CHARACTER*8 MDLNA
14008 INTEGER ISWMDL,IPAMDL
14009 DOUBLE PRECISION PARMDL
14010 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14011C data on most recent hard scattering
14012 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14013 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14014 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14015 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14016 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14017 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14018 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14019 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14020 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14021C obsolete cut-off information
14022 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14023 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14024
14025 IREJ = 0
14026
14027 IF(IDEB(32).GE.10) THEN
14028 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14029 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14030 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14031 DO 30 I=1,2
14032 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14033 30 CONTINUE
14034 ENDIF
14035
14036 FAC1 = 1.D0-XSUM1
14037 FAC2 = 1.D0-XSUM2
14038 FAC = FAC1*FAC2
14039 GAM1 = XPOT1(1)+1.D0
14040 GAM2 = XPOT2(1)+1.D0
14041 BET1 = XPOT1(2)+1.D0
14042 BET2 = XPOT2(2)+1.D0
14043
14044 ITRY0 = 0
14045 DO 100 I=1,IPAMDL(182)
14046
14047 ITRY1 = 0
14048 10 CONTINUE
14049 X1 = PHO_RNDBET(GAM1,BET1)
14050 ITRY1 = ITRY1+1
14051 IF(ITRY1.GE.50) GOTO 1000
14052 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14053
14054 ITRY2 = 0
14055 11 CONTINUE
14056 X2 = PHO_RNDBET(GAM2,BET2)
14057 ITRY2 = ITRY2+1
14058 IF(ITRY2.GE.50) GOTO 1000
14059 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14060
14061 X3 = 1.D0 - X1
14062 X4 = 1.D0 - X2
14063 IF(X1*X2*FAC.GT.AS) THEN
14064 IF(X3*X4*FAC.GT.AS) THEN
14065 XS1(1) = X1*FAC1
14066 XS1(2) = X3*FAC1
14067 XS2(1) = X2*FAC2
14068 XS2(2) = X4*FAC2
14069 IF(XS1(1).GT.XMIN(1,1)) THEN
14070 IF(XS2(1).GT.XMIN(2,1)) THEN
14071 IF(XS1(2).GT.XMIN(1,2)) THEN
14072 IF(XS2(2).GT.XMIN(2,2)) THEN
14073 XSUM1 = XSUM1+XS1(2)
14074 XSUM2 = XSUM2+XS2(2)
14075 GOTO 300
14076 ENDIF
14077 ENDIF
14078 ENDIF
14079 ENDIF
14080 ENDIF
14081 ENDIF
14082 ITRY0 = ITRY0+1
14083
14084 100 CONTINUE
14085
14086 1000 CONTINUE
14087 IREJ = 1
14088 IF(IDEB(32).GE.2) THEN
14089 WRITE(LO,'(1X,A,3I4)')
14090 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14091 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14092 ENDIF
14093 RETURN
14094 300 CONTINUE
14095
14096 END
14097
14098*$ CREATE PHO_SELSXS.FOR
14099*COPY PHO_SELSXS
14100CDECK ID>, PHO_SELSXS
14101 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14102 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14103C***********************************************************************
14104C
14105C select x values of soft string ends (rescaling method)
14106C
14107C***********************************************************************
14108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14109 SAVE
14110
14111 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14112
14113C input/output channels
14114 INTEGER LI,LO
14115 COMMON /POINOU/ LI,LO
14116C event debugging information
14117 INTEGER NMAXD
14118 PARAMETER (NMAXD=100)
14119 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14120 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14121 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14122 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14123C model switches and parameters
14124 CHARACTER*8 MDLNA
14125 INTEGER ISWMDL,IPAMDL
14126 DOUBLE PRECISION PARMDL
14127 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14128C data on most recent hard scattering
14129 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14130 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14131 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14132 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14133 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14134 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14135 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14136 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14137 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14138C obsolete cut-off information
14139 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14140 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14141
14142 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14143
14144 IREJ = 0
14145
14146 10 CONTINUE
14147
14148 IF(MSOFT.EQ.1) THEN
14149 XSOFT1(1) = 1.D0-XS1
14150 XSOFT1(2) = 0.D0
14151 XSOFT2(1) = 1.D0-XS2
14152 XSOFT2(2) = 0.D0
14153 RETURN
14154 ENDIF
14155
14156 DO 50 I=1,MSOFT
14157 POT(1,I) = XPOT1(I)+1.D0
14158 POT(2,I) = XPOT2(I)+1.D0
14159 REVP(1,I) = 1.D0/POT(1,I)
14160 REVP(2,I) = 1.D0/POT(2,I)
14161 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14162 XLMAX = XMAX1**POT(1,I)
14163 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14164 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14165 XLMAX = XMAX2**POT(2,I)
14166 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14167 50 CONTINUE
14168
14169 ITRY0 = 0
14170 5 CONTINUE
14171 ITRY0 = ITRY0 + 1
14172 IF(ITRY0.GE.IPAMDL(180)) THEN
14173 IF(MSOFT-MSMIN.GE.2) THEN
14174 MSOFT= MSMIN
14175 GOTO 10
14176 ENDIF
14177 GOTO 1000
14178 ENDIF
14179 XSUM1 = 0.D0
14180 XSUM2 = 0.D0
14181 DO 100 I=1,MSOFT
14182 ITRY1 = 0
14183 20 CONTINUE
14184 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14185 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14186 XSOFT1(I) = Z1**REVP(1,I)
14187 XSOFT2(I) = Z2**REVP(2,I)
14188 ITRY1 = ITRY1+1
14189 IF(ITRY1.GE.50) GOTO 1000
14190 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14191 XSUM1 = XSUM1+XSOFT1(I)
14192 XSUM2 = XSUM2+XSOFT2(I)
14193 100 CONTINUE
14194 FAC1 = (1.D0-XS1)/XSUM1
14195 FAC2 = (1.D0-XS2)/XSUM2
14196 DO 200 I=1,MSOFT
14197 XSOFT1(I) = XSOFT1(I)*FAC1
14198 XSOFT2(I) = XSOFT2(I)*FAC2
14199 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14200 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14201 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14202 200 CONTINUE
14203
14204 XS1 = 1.D0-XSOFT1(1)
14205 XS2 = 1.D0-XSOFT2(1)
14206 RETURN
14207
14208 1000 CONTINUE
14209 IREJ = 1
14210 IF(IDEB(14).GE.2) THEN
14211 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14212 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14213 DO 300 I=1,MSOFT
14214 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14215 300 CONTINUE
14216 ENDIF
14217
14218 END
14219
14220*$ CREATE PHO_SELSXI.FOR
14221*COPY PHO_SELSXI
14222CDECK ID>, PHO_SELSXI
14223 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14224 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14225C***********************************************************************
14226C
14227C select x values of soft string ends (sea independent from valence)
14228C
14229C***********************************************************************
14230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14231 SAVE
14232
14233 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14234
14235C input/output channels
14236 INTEGER LI,LO
14237 COMMON /POINOU/ LI,LO
14238C event debugging information
14239 INTEGER NMAXD
14240 PARAMETER (NMAXD=100)
14241 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14242 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14243 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14244 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14245C model switches and parameters
14246 CHARACTER*8 MDLNA
14247 INTEGER ISWMDL,IPAMDL
14248 DOUBLE PRECISION PARMDL
14249 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14250C data on most recent hard scattering
14251 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14252 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14253 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14254 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14255 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14256 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14257 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14258 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14259 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14260C obsolete cut-off information
14261 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14262 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14263
14264 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14265
14266 IREJ = 0
14267
14268 10 CONTINUE
14269
14270 DO 50 I=1,MSOFT
14271 POT(1,I) = XPOT1(I)+1.D0
14272 POT(2,I) = XPOT2(I)+1.D0
14273 REVP(1,I) = 1.D0/POT(1,I)
14274 REVP(2,I) = 1.D0/POT(2,I)
14275 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14276 XLMAX = XMAX1**POT(1,I)
14277 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14278 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14279 XLMAX = XMAX2**POT(2,I)
14280 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14281 50 CONTINUE
14282
14283C selection of sea
14284 ITRY0 = 0
14285 5 CONTINUE
14286
14287 ITRY0 = ITRY0 + 1
14288 IF(ITRY0.GE.IPAMDL(183)) THEN
14289 IF(MSOFT-MSMIN.GE.2) THEN
14290 MSOFT = MSMIN
14291 GOTO 10
14292 ENDIF
14293 GOTO 1000
14294 ENDIF
14295 XSUM1 = XS1
14296 XSUM2 = XS2
14297 DO 100 I=3,MSOFT
14298 ITRY1 = 0
14299 20 CONTINUE
14300 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14301 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14302 XSOFT1(I) = Z1**REVP(1,I)
14303 XSOFT2(I) = Z2**REVP(2,I)
14304 ITRY1 = ITRY1+1
14305 IF(ITRY1.GE.50) GOTO 1000
14306 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14307 XSUM1 = XSUM1+XSOFT1(I)
14308 XSUM2 = XSUM2+XSOFT2(I)
14309 100 CONTINUE
14310
14311 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14312 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14313
14314C selection of valence
14315 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14316 & XSOFT1,XSOFT2,IREJ)
14317 IF(IREJ.NE.0) THEN
14318 IF(MSOFT-MSMIN.GE.2) THEN
14319 MSOFT = MSMIN
14320 GOTO 10
14321 ENDIF
14322 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14323 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14324 & XSUM1,XSUM2,XMAX1,XMAX2
14325 RETURN
14326 ENDIF
14327
14328 XS1 = 1.D0-XSOFT1(1)
14329 XS2 = 1.D0-XSOFT2(1)
14330 RETURN
14331
14332 1000 CONTINUE
14333 IREJ = 1
14334 IF(IDEB(14).GE.2) THEN
14335 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14336 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14337 DO 300 I=1,MSOFT
14338 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14339 300 CONTINUE
14340 ENDIF
14341
14342 END
14343
14344*$ CREATE PHO_SELCOL.FOR
14345*COPY PHO_SELCOL
14346CDECK ID>, PHO_SELCOL
14347 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14348C********************************************************************
14349C
14350C color combinatorics
14351C
14352C input: ICO1,2 colors of incoming particle
14353C IMODE -2 output of initialization status
14354C -1 initialization
14355C ICINP(1) selection mode
14356C 0 QCD
14357C 1 large N_c expansion
14358C ICINP(2) max. allowed color
14359C 0 clear internal color counter
14360C 1 hadron into two colored objects
14361C 2 quark into quark gluon
14362C 3 gluon into gluon gluon
14363C 4 gluon into quark antiquark
14364C
14365C output: ICOA1,2 colors of first outgoing particle
14366C ICOB1,2 colors of second outgoing particle
14367C
14368C********************************************************************
14369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14370 SAVE
14371
14372C input/output channels
14373 INTEGER LI,LO
14374 COMMON /POINOU/ LI,LO
14375C event debugging information
14376 INTEGER NMAXD
14377 PARAMETER (NMAXD=100)
14378 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14379 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14380 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14381 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14382
14383 DATA METHOD /0/, II /0/
14384
14385 ICI1 = ICO1
14386 ICI2 = ICO2
14387 IF(METHOD.EQ.0) THEN
14388
14389 IF(IMODE.EQ.1) THEN
14390 II = II+1
14391 IF(II.GT.MAXCOL)
14392 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14393 ICOA1 = II
14394 ICOA2 = 0
14395 ICOB1 = -II
14396 ICOB2 = 0
14397 ELSE IF(IMODE.EQ.2) THEN
14398 II = II+1
14399 IF(II.GT.MAXCOL)
14400 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14401 ICOA2 = 0
14402 IF(ICI1.GT.0) THEN
14403 ICOA1 = II
14404 ICOB1 = ICI1
14405 ICOB2 = -II
14406 ELSE
14407 ICOA1 = -II
14408 ICOB1 = II
14409 ICOB2 = ICI1
14410 ENDIF
14411 ELSE IF(IMODE.EQ.3) THEN
14412 II = II+1
14413 IF(II.GT.MAXCOL)
14414 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14416 ICOA1 = ICI1
14417 ICOA2 = -II
14418 ICOB1 = II
14419 ICOB2 = ICI2
14420 ELSE
14421 ICOB1 = ICI1
14422 ICOB2 = -II
14423 ICOA1 = II
14424 ICOA2 = ICI2
14425 ENDIF
14426 ELSE IF(IMODE.EQ.4) THEN
14427 ICOA1 = ICI1
14428 ICOA2 = 0
14429 ICOB1 = ICI2
14430 ICOB2 = 0
14431 ELSE IF(IMODE.EQ.0) THEN
14432 II = 0
14433 ELSE IF(IMODE.EQ.-1) THEN
14434 METHOD = ICI1
14435 MAXCOL = ICI2
14436 ELSE IF(IMODE.EQ.-2) THEN
14437 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14438 & METHOD,MAXCOL
14439 ELSE
14440 WRITE(LO,'(1X,A,I5)')
14441 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14442 CALL PHO_ABORT
14443 ENDIF
14444
14445 ELSE
14446 WRITE(LO,'(1X,A,I5)')
14447 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14448 CALL PHO_ABORT
14449 ENDIF
14450
14451 II = ABS(II)
14452 IF(IDEB(75).GE.10) THEN
14453 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14454 & IMODE,MAXCOL,II
14455 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14456 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14457 ENDIF
14458
14459 END
14460
14461*$ CREATE ipho_diqu.FOR
14462*COPY ipho_diqu
14463CDECK ID>, ipho_diqu
14464 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14465C***********************************************************************
14466C
14467C selection of diquark number (PDG convention)
14468C
14469C***********************************************************************
14470 IMPLICIT NONE
14471 SAVE
14472
14473 integer iq1,iq2
14474
14475C input/output channels
14476 INTEGER LI,LO
14477 COMMON /POINOU/ LI,LO
14478C event debugging information
14479 INTEGER NMAXD
14480 PARAMETER (NMAXD=100)
14481 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14482 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14483 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14484 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14485C model switches and parameters
14486 CHARACTER*8 MDLNA
14487 INTEGER ISWMDL,IPAMDL
14488 DOUBLE PRECISION PARMDL
14489 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14490
14491C external functions
14492 double precision DT_RNDM
14493
14494C local variables
14495 integer i0,i1,i2
14496 double precision dum
14497
14498 i1 = abs(iq1)
14499 i2 = abs(iq2)
14500
14501 if(i1.eq.i2) then
14502 i0 = i1*1100+3
14503 else
14504 i0 = max(i1,i2)*1000+min(i1,i2)*100
14505 if(DT_RNDM(dum).gt.PARMDL(135)) then
14506 i0 = i0+1
14507 else
14508 i0 = i0+3
14509 endif
14510 endif
14511
14512 ipho_diqu = sign(i0,iq1)
14513
14514 END
14515
14516*$ CREATE PHO_PARREM.FOR
14517*COPY PHO_PARREM
14518CDECK ID>, PHO_PARREM
14519 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14520C**********************************************************************
14521C
14522C selection of particle remnant flavour(s) (quark or diquark)
14523C
14524C input: INDX index of particle in /POEVT1/
14525C IOUT parton which was taken out
14526C
14527C output: IREM remnant according to valence flavours
14528C IREJ 0 flavour combination possible
14529C 1 flavour combination impossible
14530C
14531C all particle ID are given according to PDG conventions
14532C
14533C**********************************************************************
14534 IMPLICIT NONE
14535 SAVE
14536
14537 integer INDX,IOUT,IREM,IREJ
14538
14539C input/output channels
14540 INTEGER LI,LO
14541 COMMON /POINOU/ LI,LO
14542C event debugging information
14543 INTEGER NMAXD
14544 PARAMETER (NMAXD=100)
14545 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14546 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14547 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14548 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14549C standard particle data interface
14550 INTEGER NMXHEP
14551 PARAMETER (NMXHEP=4000)
14552 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14553 DOUBLE PRECISION PHEP,VHEP
14554 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14555 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14556 & VHEP(4,NMXHEP)
14557C extension to standard particle data interface (PHOJET specific)
14558 INTEGER IMPART,IPHIST,ICOLOR
14559 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14560C general particle data
14561 double precision xm_list,tau_list,gam_list,
14562 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14563 & xm_bb82_list,xm_bb102_list
14564 integer ich3_list,iba3_list,iq_list,
14565 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14566 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14567 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14568 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14569 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14570 & ich3_list(300),iba3_list(300),iq_list(3,300),
14571 & id_psm_list(6,6),id_vem_list(6,6),
14572 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14573
14574C external functions
14575 integer ipho_diqu
14576
14577C local variables
14578 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14579 dimension IQUA(3),IDQ(2)
14580
14581 ID1 = IDHEP(INDX)
14582 ID2 = IMPART(INDX)
14583 IREJ = 0
14584
14585 IF(ID2.EQ.0) THEN
14586 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14587 CALL PHO_ABORT
14588 ENDIF
14589
14590C particle with flavour mixing
14591 if(ID1.eq.22) then
14592C photon
14593 IREM = -IOUT
14594 GOTO 100
14595 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14596C pi0, rho0, and omega
14597 IF(ABS(IOUT).LE.2) THEN
14598 IREM = -IOUT
14599 GOTO 100
14600 ELSE
14601 GOTO 150
14602 ENDIF
14603 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14604C neutral kaons (K0,K0-bar)
14605 if(abs(IOUT).eq.1) then
14606 IREM = sign(3,-IOUT)
14607 goto 100
14608 else if(abs(IOUT).eq.3) then
14609 IREM = sign(1,-IOUT)
14610 goto 100
14611 else
14612 goto 150
14613 endif
14614 else if((ID1.eq.990).or.(ID1.eq.110)) then
14615C pomeron and reggeon
14616 IREM = -IOUT
14617 GOTO 100
14618 endif
14619
14620C ordinary hadron
14621 ID = abs(ID2)
14622 IS = sign(1,ID2)
14623 IQUA(1) = iq_list(1,ID)*IS
14624 IQUA(2) = iq_list(2,ID)*IS
14625 IQUA(3) = iq_list(3,ID)*IS
14626
14627C compare to flavour content
14628 IF(ABS(IOUT).LT.1000) THEN
14629C single quark requested
14630 IF(IQUA(1).EQ.IOUT) THEN
14631 K1 = 2
14632 K2 = 3
14633 ELSE IF(IQUA(2).EQ.IOUT) THEN
14634 K1 = 1
14635 K2 = 3
14636 ELSE IF(IQUA(3).EQ.IOUT) THEN
14637 K1 = 1
14638 K2 = 2
14639 ELSE
14640 GOTO 150
14641 ENDIF
14642 IF(IQUA(3).EQ.0) THEN
14643 IREM = IQUA(K1)
14644 ELSE
14645 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14646 ENDIF
14647 ELSE IF(IQUA(3).NE.0) THEN
14648C diquark requested from baryon
14649 IDQ(1) = IOUT/1000
14650 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14651 do i=1,2
14652 do k=1,3
14653 if(IDQ(i).eq.IQUA(k)) then
14654 IQUA(k) = 0
14655 goto 110
14656 endif
14657 enddo
14658 goto 150
14659 110 continue
14660 enddo
14661 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14662 ENDIF
14663
14664 100 CONTINUE
14665C debug output
14666 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14667 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14668 & INDX,ID1,ID2,IOUT,IREM
14669 RETURN
14670
14671C rejection
14672 150 CONTINUE
14673 IREJ = 1
14674 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14675 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14676
14677 END
14678
14679*$ CREATE PHO_VALFLA.FOR
14680*COPY PHO_VALFLA
14681CDECK ID>, PHO_VALFLA
14682 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14683C***********************************************************************
14684C
14685C selection of valence flavour decomposition of particle IPAR
14686C
14687C input: IPAR particle index in /POEVT1/
14688C -1 initialization
14689C -2 output of statistics
14690C XMASS mass of particle
14691C (important for pomeron:
14692C mass dependent flavour sampling)
14693C
14694C output: IFL1,IFL2
14695C baryon: IFL1 diquark flavour
14696C (valence flavours according to PDG conventions)
14697C
14698C***********************************************************************
14699 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14700 SAVE
14701
14702 PARAMETER ( EPS = 0.1D0,
14703 & DEPS = 1.D-15)
14704
14705C input/output channels
14706 INTEGER LI,LO
14707 COMMON /POINOU/ LI,LO
14708C event debugging information
14709 INTEGER NMAXD
14710 PARAMETER (NMAXD=100)
14711 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14712 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14713 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14714 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14715C model switches and parameters
14716 CHARACTER*8 MDLNA
14717 INTEGER ISWMDL,IPAMDL
14718 DOUBLE PRECISION PARMDL
14719 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14720C standard particle data interface
14721 INTEGER NMXHEP
14722 PARAMETER (NMXHEP=4000)
14723 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14724 DOUBLE PRECISION PHEP,VHEP
14725 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14726 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14727 & VHEP(4,NMXHEP)
14728C extension to standard particle data interface (PHOJET specific)
14729 INTEGER IMPART,IPHIST,ICOLOR
14730 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14731C general particle data
14732 double precision xm_list,tau_list,gam_list,
14733 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14734 & xm_bb82_list,xm_bb102_list
14735 integer ich3_list,iba3_list,iq_list,
14736 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14737 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14738 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14739 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14740 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14741 & ich3_list(300),iba3_list(300),iq_list(3,300),
14742 & id_psm_list(6,6),id_vem_list(6,6),
14743 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14744
14745 data ITMX / 5 /
14746
14747 IF(IPAR.GT.0) THEN
14748 K = IPAR
14749C select particle code
14750 ID1 = IDHEP(K)
14751 ID = abs(IMPART(K))
14752 IBAR = IPHO_BAR3(K,2)
14753 ITER = 0
14754
14755 10 CONTINUE
14756
14757 ifl1 = 0
14758 ifl2 = 0
14759 ITER = ITER+1
14760 if(ITER.GT.ITMX) then
14761 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14762 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14763 return
14764 endif
14765
14766C not baryon
14767 IF(IBAR.EQ.0) THEN
14768
14769C photon
14770 IF(ID1.EQ.22) THEN
14771C charge dependent flavour sampling
14772 15 CONTINUE
14773 K = INT(DT_RNDM(E1)*6.D0)+1
14774 IF(K.LE.4) THEN
14775 IFL1 = 2
14776 IFL2 = -2
14777 ELSE IF(K.EQ.5) THEN
14778 IFL1 = 1
14779 IFL2 = -1
14780 ELSE
14781 IFL1 = 3
14782 IFL2 = -3
14783 ENDIF
14784C optional strangeness suppression
14785 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14786 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14787 K = IFL1
14788 IFL1 = IFL2
14789 IFL2 = K
14790 ENDIF
14791
14792C pomeron, reggeon
14793 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14794 IF(ISWMDL(19).EQ.0) THEN
14795C SU(3) symmetric valences
14796 K = INT(DT_RNDM(E1)*3.D0)+1
14797 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14798 IFL1 = K
14799 ELSE
14800 IFL1 = -K
14801 ENDIF
14802 IFL2 = -IFL1
14803 ELSE IF(ISWMDL(19).EQ.1) THEN
14804C mass dependent flavour sampling
14805 EMIN = MIN(E1,E2)
14806 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14807 ELSE
14808 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14809 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14810 CALL PHO_ABORT
14811 ENDIF
14812
14813C meson with flavour mixing
14814 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14815 K = INT(2.D0*DT_RNDM(E1))+1
14816 IFL1 = K
14817 IFL2 = -K
14818C meson (standard)
14819 ELSE
14820 K = INT(2.D0*DT_RNDM(E1))+1
14821 IFL1 = iq_list(K,ID)
14822 K = MOD(K,2) + 1
14823 IFL2 = iq_list(K,ID)
14824 if(IFL1.EQ.0) then
14825 EMIN = MIN(E1,E2)
14826 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14827 endif
14828 ENDIF
14829
14830C baryon
14831 ELSE
14832 K = INT(2.999999D0*DT_RNDM(E2))+1
14833 K1 = MOD(K,3)+1
14834 K2 = MOD(K1,3)+1
14835 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14836 IFL2 = iq_list(K,ID)
14837 ENDIF
14838
14839C change sign for antiparticles
14840 if(ID1.lt.0) then
14841 IFL1 = -IFL1
14842 IFL2 = -IFL2
14843 endif
14844
14845************************************************************************
14846C check kinematic constraints
14847* IF((PHO_PMASS(IFL1,3).GT.E1)
14848* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14849************************************************************************
14850
14851C debug output
14852 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14853 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14854
14855 ELSE IF(IPAR.EQ.-1) THEN
14856C initialization
14857
14858 ELSE IF(IPAR.EQ.-2) THEN
14859C output of final statistics
14860
14861 ELSE
14862 WRITE(LO,'(1X,A,I10)')
14863 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14864 CALL PHO_ABORT
14865 ENDIF
14866
14867 END
14868
14869*$ CREATE PHO_REGFLA.FOR
14870*COPY PHO_REGFLA
14871CDECK ID>, PHO_REGFLA
14872 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14873C**********************************************************************
14874C
14875C selection of reggeon flavours
14876C
14877C input: JM1,JM2 position index of mother hadrons
14878C
14879C output: IFLR1,IFLR2 valence flavours according to
14880C PDG conventions and JM1,JM2
14881C IREJ 0 reggeon possible
14882C 1 reggeon impossible
14883C
14884C**********************************************************************
14885 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14886 SAVE
14887
14888 PARAMETER ( EPS = 0.1D0,
14889 & DEPS = 1.D-15)
14890
14891C input/output channels
14892 INTEGER LI,LO
14893 COMMON /POINOU/ LI,LO
14894C event debugging information
14895 INTEGER NMAXD
14896 PARAMETER (NMAXD=100)
14897 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14898 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14899 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14900 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14901C nucleon-nucleus / nucleus-nucleus interface to DPMJET
14902 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14903 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14904 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14905 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14906C standard particle data interface
14907 INTEGER NMXHEP
14908 PARAMETER (NMXHEP=4000)
14909 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14910 DOUBLE PRECISION PHEP,VHEP
14911 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14912 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14913 & VHEP(4,NMXHEP)
14914C extension to standard particle data interface (PHOJET specific)
14915 INTEGER IMPART,IPHIST,ICOLOR
14916 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14917
14918 IF(JM1.GT.0) THEN
14919 IREJ = 0
14920 ITER = 0
14921C available energy
14922 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14923 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
14924 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
14925 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14926 50 CONTINUE
14927 ITER = ITER+1
14928 IF(ITER.GT.50) THEN
14929 IREJ = 1
14930C debug output
14931 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14932 & 'PHO_REGFLA: rejection, no reggeon found for',
14933 & IDHEP(JM1),IDHEP(JM2),E1
14934 RETURN
14935 ENDIF
14936
14937 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14938 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14939 IF(IFLA1.EQ.-IFLB1) THEN
14940 IFLR1 = IFLA2
14941 IFLR2 = IFLB2
14942 ELSE IF(IFLA1.EQ.-IFLB2) THEN
14943 IFLR1 = IFLA2
14944 IFLR2 = IFLB1
14945 ELSE IF(IFLA2.EQ.-IFLB1) THEN
14946 IFLR1 = IFLA1
14947 IFLR2 = IFLB2
14948 ELSE IF(IFLA2.EQ.-IFLB2) THEN
14949 IFLR1 = IFLA1
14950 IFLR2 = IFLB1
14951 ELSE
14952C debug output
14953 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14954 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14955 GOTO 50
14956 ENDIF
14957C debug output
14958 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14959 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14960 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14961 ELSE IF(JM1.EQ.-1) THEN
14962C initialization
14963 ELSE IF(JM1.EQ.-2) THEN
14964C output of statistics
14965 ELSE
14966 WRITE(LO,'(1X,A,I10)')
14967 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
14968 CALL PHO_ABORT
14969 ENDIF
14970
14971 END
14972
14973*$ CREATE PHO_SEAFLA.FOR
14974*COPY PHO_SEAFLA
14975CDECK ID>, PHO_SEAFLA
14976 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14977C**********************************************************************
14978C
14979C selection of sea flavour content of particle IPAR
14980C
14981C input: IPAR particle index in /POEVT1/
14982C CHMASS available invariant string mass
14983C positive mass --> use BAMJET method
14984C negative mass --> SU(3) symmetric sea according
14985C to values given in PARMDL(1-6)
14986C IPAR -1 initialization
14987C -2 output of statistics
14988C
14989C output: sea flavours according to PDG conventions
14990C
14991C**********************************************************************
14992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14993 SAVE
14994
14995 PARAMETER ( EPS = 0.1D0,
14996 & DEPS = 1.D-15)
14997
14998C input/output channels
14999 INTEGER LI,LO
15000 COMMON /POINOU/ LI,LO
15001C event debugging information
15002 INTEGER NMAXD
15003 PARAMETER (NMAXD=100)
15004 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15005 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15006 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15007 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15008C model switches and parameters
15009 CHARACTER*8 MDLNA
15010 INTEGER ISWMDL,IPAMDL
15011 DOUBLE PRECISION PARMDL
15012 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15013C some hadron information, will be deleted in future versions
15014 INTEGER NFS
15015 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15016 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15017
15018 IF(IPAR.GT.0) THEN
15019 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15020C constant weights for sea
15021 15 CONTINUE
15022 SUM = 0.D0
15023 DO 40 K=1,NFSEA
15024 SUM = SUM + PARMDL(K)
15025 40 CONTINUE
15026 XI = DT_RNDM(SUM)*SUM
15027 SUM = 0.D0
15028 DO 50 K=1,NFSEA
15029 SUM = SUM + PARMDL(K)
15030 IF(XI.LE.SUM) GOTO 55
15031 50 CONTINUE
15032 55 CONTINUE
15033 IF(K.GT.NFSEA) GOTO 15
15034 ELSE
15035C mass dependent flavour sampling
15036 10 CONTINUE
15037 CALL PHO_FLAUX(CHMASS,K)
15038 IF(K.GT.NFSEA) GOTO 10
15039 ENDIF
15040 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15041 IFL1 = K
15042 IFL2 = -K
15043 IF(IDEB(46).GE.10) THEN
15044 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15045 & IPAR,IFL1,IFL2,CHMASS
15046 ENDIF
15047 ELSE IF(IPAR.EQ.-1) THEN
15048C initialization
15049 NFSEA = NFS
15050 ELSE IF(IPAR.EQ.-2) THEN
15051C output of statistics
15052 ELSE
15053 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15054 CALL PHO_ABORT
15055 ENDIF
15056
15057 END
15058
15059*$ CREATE PHO_FLAUX.FOR
15060*COPY PHO_FLAUX
15061CDECK ID>, PHO_FLAUX
15062 SUBROUTINE PHO_FLAUX(EQUARK,K)
15063C***********************************************************************
15064C
15065C auxiliary subroutine to select flavours
15066C
15067C********************************************************************
15068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15069 SAVE
15070
15071 PARAMETER ( DEPS = 1.D-14 )
15072
15073C input/output channels
15074 INTEGER LI,LO
15075 COMMON /POINOU/ LI,LO
15076C event debugging information
15077 INTEGER NMAXD
15078 PARAMETER (NMAXD=100)
15079 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15080 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15081 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15082 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15083C some hadron information, will be deleted in future versions
15084 INTEGER NFS
15085 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15086 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15087
15088 DIMENSION WGHT(9)
15089
15090C calculate weights for given energy
15091 IF(EQUARK.LT.QMASS(1)) THEN
15092 IF(IDEB(16).GE.5)
15093 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15094 & EQUARK
15095 WGHT(1) = 0.5D0
15096 WGHT(2) = 0.5D0
15097 WGHT(3) = 0.D0
15098 WGHT(4) = 0.D0
15099 SUM = 1.D0
15100 ELSE
15101 SUM = 0.D0
15102 DO 305 K=1,NFS
15103 IF(EQUARK.GT.QMASS(K)) THEN
15104 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15105 ELSE
15106 WGHT(K) = 0.D0
15107 ENDIF
15108 SUM = SUM + WGHT(K)
15109 305 CONTINUE
15110 ENDIF
15111C sample flavours
15112 XI = SUM*(DT_RNDM(SUM)-DEPS)
15113 K = 0
15114 SUM = 0.D0
15115 400 CONTINUE
15116 K = K+1
15117 SUM = SUM + WGHT(K)
15118 IF(XI.GT.SUM) GOTO 400
15119C debug output
15120 IF(IDEB(16).GE.20) THEN
15121 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15122 ENDIF
15123 END
15124
15125*$ CREATE PHO_BETAF.FOR
15126*COPY PHO_BETAF
15127CDECK ID>, PHO_BETAF
15128 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15129C********************************************************************
15130C
15131C weights of different quark flavours
15132C
15133C********************************************************************
15134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15135 SAVE
15136
15137 AX=0.D0
15138 BETX1=BET*X1
15139 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15140 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15141
15142 PHO_BETAF=AX+AY
15143
15144 END
15145
15146*$ CREATE PHO_MCHECK.FOR
15147*COPY PHO_MCHECK
15148CDECK ID>, PHO_MCHECK
15149 SUBROUTINE PHO_MCHECK(J1,IREJ)
15150C********************************************************************
15151C
15152C check parton momenta for fragmentation
15153C
15154C input: J1 first string number
15155C /POEVT1/
15156C /POSTRG/
15157C
15158C output: /POEVT1/
15159C /POSTRG/
15160C IREJ 0 successful
15161C 1 failure
15162C
15163C in case of very small string mass:
15164C NNCH mass label of string
15165C 0 string
15166C -1 octett baryon / pseudo scalar meson
15167C 1 decuplett baryon / vector meson
15168C IBHAD hadron number according to CPC,
15169C string will be treated as resonance
15170C (sometimes far off mass shell)
15171C
15172C constant WIDTH ( 0.01GeV ) determines range of acceptance
15173C
15174C********************************************************************
15175 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15176 SAVE
15177
15178 PARAMETER ( WIDTH = 0.01D0,
15179 & DEPS = 1.D-15 )
15180
15181C input/output channels
15182 INTEGER LI,LO
15183 COMMON /POINOU/ LI,LO
15184C event debugging information
15185 INTEGER NMAXD
15186 PARAMETER (NMAXD=100)
15187 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15188 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15189 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15190 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15191C model switches and parameters
15192 CHARACTER*8 MDLNA
15193 INTEGER ISWMDL,IPAMDL
15194 DOUBLE PRECISION PARMDL
15195 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15196C standard particle data interface
15197 INTEGER NMXHEP
15198 PARAMETER (NMXHEP=4000)
15199 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15200 DOUBLE PRECISION PHEP,VHEP
15201 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15202 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15203 & VHEP(4,NMXHEP)
15204C extension to standard particle data interface (PHOJET specific)
15205 INTEGER IMPART,IPHIST,ICOLOR
15206 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15207C color string configurations including collapsed strings and hadrons
15208 INTEGER MSTR
15209 PARAMETER (MSTR=500)
15210 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15211 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15212 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15213 & NNCH(MSTR),IBHAD(MSTR),ISTR
15214C internal rejection counters
15215 INTEGER NMXJ
15216 PARAMETER (NMXJ=60)
15217 CHARACTER*10 REJTIT
15218 INTEGER IFAIL
15219 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15220
15221 IREJ = 0
15222C quark antiquark jet
15223 STRM = PHEP(5,NPOS(1,J1))
15224 IF(NCODE(J1).EQ.3) THEN
15225 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15226 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15227 IF(IDEB(18).GE.5)
15228 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15229 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15230 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15231 IF(STRM.LT.AMPS) THEN
15232 IREJ = 1
15233 IFAIL(20) = IFAIL(20) + 1
15234 RETURN
15235 ELSE IF(STRM.LT.AMPS2) THEN
15236 IF(STRM.LT.(AMVE-WIDTH)) THEN
15237 NNCH(J1) = -1
15238 IBHAD(J1) = IPS
15239 ELSE
15240 NNCH(J1) = 1
15241 IBHAD(J1) = IVE
15242 ENDIF
15243 ELSE
15244 NNCH(J1) = 0
15245 IBHAD(J1) = 0
15246 ENDIF
15247C quark diquark or v.s. jet
15248 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15249 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15250 & AM8,AM82,AM10,AM102,I8,I10)
15251 IF(IDEB(18).GE.5)
15252 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15253 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15254 & J1,STRM,AM8,AM82,AM10,AM102
15255 IF(STRM.LT.AM8) THEN
15256 IREJ = 1
15257 IFAIL(19) = IFAIL(19) + 1
15258 RETURN
15259 ELSE IF(STRM.LT.AM82) THEN
15260 IF(STRM.LT.(AM10-WIDTH)) THEN
15261 NNCH(J1) = -1
15262 IBHAD(J1) = I8
15263 ELSE
15264 NNCH(J1) = 1
15265 IBHAD(J1) = I10
15266 ENDIF
15267 ELSE
15268 NNCH(J1) = 0
15269 IBHAD(J1) = 0
15270 ENDIF
15271C diquark a-diquark string
15272 ELSE IF(NCODE(J1).EQ.5) THEN
15273 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15274 & AM82,AM102)
15275 IF(IDEB(18).GE.5)
15276 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15277 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15278 & J1,STRM,AM82,AM102
15279 IF(STRM.LT.AM82) THEN
15280 IREJ = 1
15281 IFAIL(19) = IFAIL(19) + 1
15282 RETURN
15283 ELSE
15284 NNCH(J1) = 0
15285 IBHAD(J1) = 0
15286 ENDIF
15287 ELSE IF(NCODE(J1).LT.0) THEN
15288 RETURN
15289 ELSE
15290 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15291 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15292 CALL PHO_ABORT
15293 ENDIF
15294 END
15295
15296*$ CREATE PHO_POMCOR.FOR
15297*COPY PHO_POMCOR
15298CDECK ID>, PHO_POMCOR
15299 SUBROUTINE PHO_POMCOR(IREJ)
15300C********************************************************************
15301C
15302C join quarks to gluons in case of too small masses
15303C
15304C input: /POEVT1/
15305C /POSTRG/
15306C IREJ -1 initialization
15307C -2 output of statistics
15308C
15309C output: /POEVT1/
15310C /POSTRG/
15311C IREJ 0 successful
15312C 1 failure
15313C
15314C
15315C********************************************************************
15316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15317 SAVE
15318
15319 PARAMETER ( EPS = 1.D-10 )
15320
15321C input/output channels
15322 INTEGER LI,LO
15323 COMMON /POINOU/ LI,LO
15324C event debugging information
15325 INTEGER NMAXD
15326 PARAMETER (NMAXD=100)
15327 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15328 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15329 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15330 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15331C model switches and parameters
15332 CHARACTER*8 MDLNA
15333 INTEGER ISWMDL,IPAMDL
15334 DOUBLE PRECISION PARMDL
15335 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15336C standard particle data interface
15337 INTEGER NMXHEP
15338 PARAMETER (NMXHEP=4000)
15339 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15340 DOUBLE PRECISION PHEP,VHEP
15341 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15342 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15343 & VHEP(4,NMXHEP)
15344C extension to standard particle data interface (PHOJET specific)
15345 INTEGER IMPART,IPHIST,ICOLOR
15346 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15347C color string configurations including collapsed strings and hadrons
15348 INTEGER MSTR
15349 PARAMETER (MSTR=500)
15350 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15351 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15352 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15353 & NNCH(MSTR),IBHAD(MSTR),ISTR
15354
15355 DIMENSION PJ(4)
15356
15357 IF(IREJ.EQ.-1) THEN
15358 ICTOT = 0
15359 ICCOR = 0
15360 RETURN
15361 ELSE IF(IREJ.EQ.-2) THEN
15362 WRITE(LO,'(/1X,A,2I8)')
15363 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15364 RETURN
15365 ENDIF
15366C
15367 IREJ = 0
15368C
15369 NITER = 100
15370 ITER = 0
15371 ICTOT = ICTOT+ISTR
15372 IF(ISWMDL(25).LE.0) RETURN
15373C debug string entries
15374 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15375C
15376 50 CONTINUE
15377 ITER = ITER+1
15378 IF(ITER.GE.NITER) THEN
15379 IREJ = 1
15380 IF(IDEB(83).GE.2) THEN
15381 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15382 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15383 ENDIF
15384 RETURN
15385 ENDIF
15386C
15387C check mass limits
15388 ISTRO = ISTR
15389 DO 100 I=1,ISTRO
15390 IF(NCODE(I).LT.0) GOTO 99
15391 J1 = NPOS(1,I)
15392 NRPOM = IPHIST(2,J1)
15393 IF(NRPOM.GE.100) GOTO 99
15394 CMASS0 = PHEP(5,J1)
15395C get masses
15396 IF(NCODE(I).EQ.3) THEN
15397 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15398 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15399 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15400 & AM1,AM2,AM3,AM4,IP1,IP2)
15401 ELSE IF(NCODE(I).EQ.5) THEN
15402 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15403 & AM1,AM2)
15404 AM3 = 0.D0
15405 AM4 = 0.D0
15406 IP1 = 0
15407 IP2 = 0
15408 ELSE IF(NCODE(I).EQ.7) THEN
15409 GOTO 99
15410 ELSE IF(NCODE(I).LT.0) THEN
15411 GOTO 99
15412 ELSE
15413 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15414 & J1,NCODE(I)
15415 CALL PHO_ABORT
15416 ENDIF
15417 IF(IDEB(83).GE.5)
15418 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15419 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15420 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15421C select masses to correct
15422 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15423 DO 200 K=1,ISTRO
15424 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15425 J2 = NPOS(1,K)
15426C join quarks to gluon
15427 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15428C flavour check
15429 IFL1 = 0
15430 IFL2 = 0
15431 PROB1 = 0.D0
15432 PROB2 = 0.D0
15433 KK1 = NPOS(2,I)
15434 KK2 = NPOS(2,K)
15435 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15436 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15437 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15438 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15439 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15440 IFL1 = ABS(IDHEP(KK1))
15441 IF(IFL1.GT.2) THEN
15442 PROB1 = 0.1D0/MAX(CMASS,EPS)
15443 ELSE
15444 PROB1 = 0.9D0/MAX(CMASS,EPS)
15445 ENDIF
15446 ENDIF
15447 KK1 = ABS(NPOS(3,I))
15448 KK2 = ABS(NPOS(3,K))
15449 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15450 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15451 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15452 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15453 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15454 IFL2 = ABS(IDHEP(KK1))
15455 IF(IFL2.GT.2) THEN
15456 PROB2 = 0.1D0/MAX(CMASS,EPS)
15457 ELSE
15458 PROB2 = 0.9D0/MAX(CMASS,EPS)
15459 ENDIF
15460 ENDIF
15461 IF(IFL1+IFL2.EQ.0) GOTO 99
15462C fusion possible
15463 ICCOR = ICCOR+1
15464 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15465 JJ = 2
15466 JE = 3
15467 ELSE
15468 JJ = 3
15469 JE = 2
15470 ENDIF
15471 KK1 = ABS(NPOS(JJ,I))
15472 KK2 = ABS(NPOS(JJ,K))
15473 I1 = ABS(NPOS(JE,I))
15474 I2 = KK1
15475 IS = SIGN(1,I2-I1)
15476 I2 = I2 - IS
15477 K1 = KK2
15478 K2 = ABS(NPOS(JE,K))
15479 KS = SIGN(1,K2-K1)
15480 K1 = K1 + KS
15481 IP1 = NHEP+1
15482C copy mother partons of string I
15483 DO 300 II=I1,I2,IS
15484 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15485 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15486 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15487 300 CONTINUE
15488C register gluon
15489 DO 350 II=1,4
15490 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15491 350 CONTINUE
15492 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15493 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15494C copy mother partons of string K
15495 DO 400 II=K1,K2,KS
15496 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15497 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15498 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15499 400 CONTINUE
15500C create new string entry
15501 DO 450 II=1,4
15502 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15503 450 CONTINUE
15504 IP2 = IPOS
15505 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15506 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15507 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15508C delete string K in /POSTRG/
15509 NCODE(K) = -999
15510C update string I in /POSTRG/
15511 NPOS(1,I) = IPOS
15512 NPOS(2,I) = IP1
15513 NPOS(3,I) = -IP2
15514C calculate new CPC string codes
15515 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15516 & IPAR2(I),IPAR3(I),IPAR4(I))
15517 GOTO 99
15518 ENDIF
15519 ENDIF
15520 200 CONTINUE
15521 ENDIF
15522 99 CONTINUE
15523 100 CONTINUE
15524 IF(IDEB(83).GE.20) THEN
15525 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15526 IF(IDEB(83).GE.22) THEN
15527 CALL PHO_PRSTRG
15528 CALL PHO_PREVNT(0)
15529 ENDIF
15530 ENDIF
15531
15532 END
15533
15534*$ CREATE PHO_MASCOR.FOR
15535*COPY PHO_MASCOR
15536CDECK ID>, PHO_MASCOR
15537 SUBROUTINE PHO_MASCOR(IREJ)
15538C********************************************************************
15539C
15540C check and adjust parton momenta for fragmentation
15541C
15542C input: /POEVT1/
15543C /POSTRG/
15544C IREJ -1 initialization
15545C -2 output of statistics
15546C
15547C output: /POEVT1/
15548C /POSTRG/
15549C IREJ 0 successful
15550C 1 failure
15551C
15552C in case of very small string mass:
15553C - direct manipulation of /POEVT1/ and /POEVT2/
15554C - string will be deleted from /POSTRG/ (label -99)
15555C
15556C********************************************************************
15557 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15558 SAVE
15559
15560 PARAMETER ( EPS = 1.D-10,
15561 & EMIN = 0.3D0,
15562 & DEPS = 1.D-15)
15563
15564C input/output channels
15565 INTEGER LI,LO
15566 COMMON /POINOU/ LI,LO
15567C event debugging information
15568 INTEGER NMAXD
15569 PARAMETER (NMAXD=100)
15570 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15571 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15572 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15573 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15574C internal rejection counters
15575 INTEGER NMXJ
15576 PARAMETER (NMXJ=60)
15577 CHARACTER*10 REJTIT
15578 INTEGER IFAIL
15579 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15580C model switches and parameters
15581 CHARACTER*8 MDLNA
15582 INTEGER ISWMDL,IPAMDL
15583 DOUBLE PRECISION PARMDL
15584 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15585C standard particle data interface
15586 INTEGER NMXHEP
15587 PARAMETER (NMXHEP=4000)
15588 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15589 DOUBLE PRECISION PHEP,VHEP
15590 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15591 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15592 & VHEP(4,NMXHEP)
15593C extension to standard particle data interface (PHOJET specific)
15594 INTEGER IMPART,IPHIST,ICOLOR
15595 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15596C color string configurations including collapsed strings and hadrons
15597 INTEGER MSTR
15598 PARAMETER (MSTR=500)
15599 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15600 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15601 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15602 & NNCH(MSTR),IBHAD(MSTR),ISTR
15603
15604 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15605
15606 IF(IREJ.EQ.-1) THEN
15607 ICTOT = 0
15608 ICCOR = 0
15609 RETURN
15610 ELSE IF(IREJ.EQ.-2) THEN
15611 WRITE(LO,'(/1X,A,2I8/)')
15612 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15613 RETURN
15614 ENDIF
15615
15616 IREJ = 0
15617 NITER = 100
15618 ITER = 0
15619 ICTOT = ICTOT+ISTR
15620 IF(ISWMDL(7).EQ.-1) RETURN
15621C debug /POSTRG/
15622 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15623
15624 ITOUCH = 0
15625 50 CONTINUE
15626 ITER = ITER+1
15627 IF(ITER.GE.NITER) THEN
15628 IREJ = 1
15629 IF(IDEB(42).GE.2) THEN
15630 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15631 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15632 ENDIF
15633 RETURN
15634 ENDIF
15635
15636C check mass limits
15637 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15638 IM1 = 1
15639 IM2 = ISTR
15640 IST = 1
15641 ELSE
15642 IM1 = ISTR
15643 IM2 = 1
15644 IST = -1
15645 ENDIF
15646 DO 100 I=IM1,IM2,IST
15647 J1 = NPOS(1,I)
15648 CMASS0 = PHEP(5,J1)
15649C get masses
15650 IF(NCODE(I).EQ.3) THEN
15651 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15652 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15653 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15654 & AM1,AM2,AM3,AM4,IP1,IP2)
15655 ELSE IF(NCODE(I).EQ.5) THEN
15656 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15657 & AM1,AM2)
15658 AM3 = 0.D0
15659 AM4 = 0.D0
15660 IP1 = 0
15661 IP2 = 0
15662 ELSE IF(NCODE(I).EQ.7) THEN
15663 AM1 = 0.15D0
15664 AM2 = 0.3D0
15665 AM3 = 0.765D0
15666 AM4 = 1.5D0
15667*??????????????????????????????????
15668 IP1 = 23
15669 IP2 = 33
15670*??????????????????????????????????
15671 ELSE IF(NCODE(I).LT.0) THEN
15672 GOTO 90
15673 ELSE
15674 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15675 & J1,NCODE(I)
15676 CALL PHO_ABORT
15677 ENDIF
15678 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15679 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15680 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15681C select masses to correct
15682 IBHAD(I) = 0
15683 NNCH(I) = 0
15684C correction needed?
15685C no resonances for diquark-antidiquark and gluon-gluon strings
15686 IF(NCODE(I).EQ.5) THEN
15687 IF(CMASS0.LT.1.3D0*AM1) THEN
15688 IF(ISWMDL(7).LE.2) THEN
15689 IBHAD(I) = 90
15690 NNCH(I) = -1
15691 CHMASS = AM1*1.3D0
15692 ELSE
15693 IREJ = 1
15694 RETURN
15695 ENDIF
15696 ENDIF
15697 ELSE
15698 INEED = 0
15699C resonances possible
15700 IF(ISWMDL(7).EQ.0) THEN
15701 IF(CMASS0.LT.AM1*0.99D0) THEN
15702 IBHAD(I) = IP1
15703 NNCH(I) = -1
15704 CHMASS = AM1
15705 INEED = 1
15706 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15707 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15708 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15709 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15710 IBHAD(I) = IP1
15711 NNCH(I) = -1
15712 CHMASS = AM1
15713 ELSE
15714 IBHAD(I) = IP2
15715 NNCH(I) = 1
15716 CHMASS = AM3
15717 ENDIF
15718 ENDIF
15719 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15720 IF(CMASS0.LT.AM1*0.99) THEN
15721 IBHAD(I) = IP1
15722 NNCH(I) = -1
15723 CHMASS = AM1
15724 INEED = 1
15725 ENDIF
15726 ELSE IF(ISWMDL(7).EQ.3) THEN
15727 IF(CMASS0.LT.AM1) THEN
15728 IREJ = 1
15729 RETURN
15730 ENDIF
15731 ELSE
15732 WRITE(LO,'(/1X,A,I5)')
15733 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15734 CALL PHO_ABORT
15735 ENDIF
15736 ENDIF
15737C
15738C correction necessary?
15739 IF(IBHAD(I).NE.0) THEN
15740C find largest invar. mass
15741 IPOS = 0
15742 CMASS1 = -1.D0
15743 DO 200 J2=NHEP,3,-1
15744 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15745 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15746 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15747 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15748 CALL PHO_PREVNT(0)
15749 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15750 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15751 & -(PHEP(1,J1)+PHEP(1,J2))**2
15752 & -(PHEP(2,J1)+PHEP(2,J2))**2
15753 & -(PHEP(3,J1)+PHEP(3,J2))**2
15754 IF(CMASS2.GT.CMASS1) THEN
15755 IPOS=J2
15756 CMASS1=CMASS2
15757 ENDIF
15758 ENDIF
15759 ENDIF
15760 200 CONTINUE
15761 J2 = IPOS
15762 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15763 IF(INEED.EQ.1) THEN
15764 IREJ = 1
15765 RETURN
15766 ELSE
15767 IBHAD(I) = 0
15768 NNCH(I) = 0
15769 GOTO 90
15770 ENDIF
15771 ENDIF
15772 ISTA = ISTHEP(J1)
15773 ISTB = ISTHEP(J2)
15774 CMASS1 = SQRT(CMASS1)
15775 CMASS2 = PHEP(5,J2)
15776 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15777 IREJ = 1
15778 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15779 & CHMASS,CMASS2,PC1,PC2,IREJ)
15780 IF(IREJ.NE.0) THEN
15781 IFAIL(24) = IFAIL(24)+1
15782 IF(IDEB(42).GE.2) THEN
15783 WRITE(LO,'(1X,A,2I4)')
15784 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15785 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15786 ENDIF
15787 IREJ = 1
15788 RETURN
15789 ENDIF
15790C momentum transfer
15791 DO 210 II=1,4
15792 PTR(II) = PHEP(II,J2)-PC2(II)
15793 210 CONTINUE
15794 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15795 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15796C copy parents of strings
15797C register partons belonging to first string
15798 IF(IDHEP(J1).EQ.90) THEN
15799 K1 = JMOHEP(1,J1)
15800 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15801 ESUM = 0.D0
15802 DO 500 II=K1,K2
15803 ESUM = ESUM+PHEP(4,II)
15804 500 CONTINUE
15805 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15806 DO 600 II=K1,K2
15807 FAC = PHEP(4,II)/ESUM
15808 DO 650 K=1,4
15809 P1(K) = PHEP(K,II)+FAC*PTR(K)
15810 650 CONTINUE
15811 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15812 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15813 & ICOLOR(2,II),IPOS,1)
15814 600 CONTINUE
15815 K1A = IPOS+K1-K2
15816 IF(JMOHEP(2,J1).GT.0) THEN
15817 II = JMOHEP(2,J1)
15818 FAC = PHEP(4,II)/ESUM
15819 DO 675 K=1,4
15820 P1(K) = PHEP(K,II)+FAC*PTR(K)
15821 675 CONTINUE
15822 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15823 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15824 & ICOLOR(2,II),IPOS,1)
15825 ENDIF
15826 K2A = -IPOS
15827 ELSE
15828 K1A = J1
15829 K2A = J2
15830 ENDIF
15831C register partons belonging to second string
15832 IF(IDHEP(J2).EQ.90) THEN
15833 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15834 K1 = JMOHEP(1,J2)
15835 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15836 ESUM = 0.D0
15837 DO 300 II=K1,K2
15838 ESUM = ESUM+PHEP(4,II)
15839 300 CONTINUE
15840 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15841 DO 400 II=K1,K2
15842**sr 28.12.2006 fix adopted from FLUKA
15843C FAC = PHEP(4,II)/ESUM
15844 IF (ABS(ESUM).GT.0.D0) THEN
15845 FAC = PHEP(4,II)/ESUM
15846 ELSE
15847 FAC = 1.0D0
15848 ENDIF
15849**
15850 IF(IREJL.EQ.0) THEN
15851 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15852 P1(4) = P1(4)+FAC*DELE
15853 ELSE
15854 DO 450 K=1,4
15855 P1(K) = PHEP(K,II)-FAC*PTR(K)
15856 450 CONTINUE
15857 ENDIF
15858 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15859 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15860 & ICOLOR(2,II),IPOS,1)
15861 400 CONTINUE
15862 K1B = IPOS+K1-K2
15863 IF(JMOHEP(2,J2).GT.0) THEN
15864 II = JMOHEP(2,J2)
15865 FAC = PHEP(4,II)/ESUM
15866 IF(IREJL.EQ.0) THEN
15867 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15868 P1(4) = P1(4)+FAC*DELE
15869 ELSE
15870 DO 475 K=1,4
15871 P1(K) = PHEP(K,II)-FAC*PTR(K)
15872 475 CONTINUE
15873 ENDIF
15874 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15875 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15876 & ICOLOR(2,II),IPOS,1)
15877 ENDIF
15878 K2B = -IPOS
15879 ELSE
15880 K1B = J1
15881 K2B = J2
15882 ENDIF
15883C register first string/collapsed to hadron
15884 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15885 IF(NCODE(I).NE.5) THEN
15886 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15887 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15888C label string as collapsed to hadron/resonance
15889 NCODE(I) = -99
15890 IDHEP(J1) = 92
15891 ELSE
15892 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15893 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15894 IDHEP(J1) = 91
15895 ENDIF
15896 NPOS(1,I) = IPOS
15897 NPOS(2,I) = K1A
15898 NPOS(3,I) = K2A
15899 ELSE
15900 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15901 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15902 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15903 IF(IDHEP(J1).EQ.90) THEN
15904 NPOS(1,IPHIST(1,J1)) = IPOS
15905 NPOS(2,IPHIST(1,J1)) = K1A
15906 NPOS(3,IPHIST(1,J1)) = K2A
15907C label string as collapsed to resonance-string
15908 IDHEP(J1) = 91
15909 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15910 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15911 ENDIF
15912 ENDIF
15913C register second string/hadron/parton
15914 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15915 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15916 & ICOLOR(2,J2),IPOS,1)
15917 IF(IDHEP(J2).EQ.90) THEN
15918 NPOS(1,IPHIST(1,J2))=IPOS
15919 NPOS(2,IPHIST(1,J2))=K1B
15920 NPOS(3,IPHIST(1,J2))=K2B
15921C label string touched by momentum transfer
15922 IDHEP(J2) = 91
15923 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15924 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15925 ENDIF
15926 ICCOR = ICCOR+1
15927 ITOUCH = ITOUCH+1
15928C consistency checks
15929 IF(IDEB(42).GE.5) THEN
15930 CALL PHO_CHECK(-1,IDEV)
15931 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15932 ENDIF
15933C jump to next iteration
15934 GOTO 50
15935 ENDIF
15936 90 CONTINUE
15937 100 CONTINUE
15938C debug output
15939 IF(IDEB(42).GE.15) THEN
15940 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15941 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15942 CALL PHO_PREVNT(1)
15943 ENDIF
15944 ENDIF
15945 END
15946
15947*$ CREATE PHO_PARCOR.FOR
15948*COPY PHO_PARCOR
15949CDECK ID>, PHO_PARCOR
15950 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15951C********************************************************************
15952C
15953C conversion of string partons (using JETSET masses)
15954C
15955C input: MODE >0 position index of corresponding string
15956C -1 initialization
15957C -2 output of statistics
15958C
15959C output: /POSTRG/
15960C IREJ 1 combination of strings impossible
15961C 0 successful combination
15962C
15963C********************************************************************
15964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15965 SAVE
15966
15967 PARAMETER ( DELM = 0.005D0,
15968 & DEPS = 1.D-15,
15969 & EPS = 1.D-5)
15970
15971C input/output channels
15972 INTEGER LI,LO
15973 COMMON /POINOU/ LI,LO
15974C event debugging information
15975 INTEGER NMAXD
15976 PARAMETER (NMAXD=100)
15977 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15978 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15979 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15980 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15981C internal rejection counters
15982 INTEGER NMXJ
15983 PARAMETER (NMXJ=60)
15984 CHARACTER*10 REJTIT
15985 INTEGER IFAIL
15986 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15987C model switches and parameters
15988 CHARACTER*8 MDLNA
15989 INTEGER ISWMDL,IPAMDL
15990 DOUBLE PRECISION PARMDL
15991 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15992C standard particle data interface
15993 INTEGER NMXHEP
15994 PARAMETER (NMXHEP=4000)
15995 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15996 DOUBLE PRECISION PHEP,VHEP
15997 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15998 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15999 & VHEP(4,NMXHEP)
16000C extension to standard particle data interface (PHOJET specific)
16001 INTEGER IMPART,IPHIST,ICOLOR
16002 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16003C color string configurations including collapsed strings and hadrons
16004 INTEGER MSTR
16005 PARAMETER (MSTR=500)
16006 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16007 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16008 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16009 & NNCH(MSTR),IBHAD(MSTR),ISTR
16010
16011 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16012 & PL(4,100),XMP(100),XML(100)
16013
16014 DOUBLE PRECISION PYMASS
16015
16016 IREJ = 0
16017 IMODE = MODE
16018C
16019 IF(IMODE.GT.0) THEN
16020 ICH = 0
16021 I1 = JMOHEP(1,IMODE)
16022 I2 = ABS(JMOHEP(2,IMODE))
16023C copy to local field
16024 L = 0
16025 DO 100 I=I1,I2
16026 L = L+1
16027 DO 200 K=1,4
16028 PL(K,L) = PHEP(K,I)
16029 200 CONTINUE
16030 XMP(L) = PHEP(5,I)
16031 XML(L) = PYMASS(IDHEP(I))
16032 100 CONTINUE
16033 IPAR = L
16034 XMC = PHEP(5,IMODE)
16035 IF(IDEB(82).GE.20) THEN
16036 WRITE(LO,'(1X,A,I7,2I4)')
16037 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16038 & KEVENT,IMODE,L
16039 DO 150 I=1,L
16040 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16041 & XMP(I),XML(I)
16042 150 CONTINUE
16043 ENDIF
16044C
16045C two parton configurations
16046C -----------------------------------------
16047 IF(IPAR.EQ.2) THEN
16048 XM1 = XML(1)
16049 XM2 = XML(2)
16050 IF((XM1+XM2).GE.XMC) THEN
16051 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16052 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16053 & IMODE,XM1,XM2,XMC
16054 GOTO 990
16055 ENDIF
16056C conversion possible
16057 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16058 IF(IREJ.NE.0) THEN
16059 IFAIL(36) = IFAIL(36)+1
16060 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16061 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16062 & KEVENT,IMODE,XMC
16063 GOTO 990
16064 ENDIF
16065 ICH = 1
16066 DO 115 K=1,4
16067 PL(K,1) = PP1(K)
16068 PL(K,2) = PP2(K)
16069 XMP(1) = XM1
16070 XMP(2) = XM2
16071 115 CONTINUE
16072C
16073C multi parton configurations
16074C ---------------------------------
16075 ELSE
16076C
16077C random selection of string side to start with
16078 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16079 K1 = 1
16080 K2 = IPAR
16081 KS = 1
16082 ELSE
16083 K1 = IPAR
16084 K2 = 1
16085 KS = -1
16086 ENDIF
16087 ITER = 0
16088C
16089 300 CONTINUE
16090 IF(ITER.LT.4) THEN
16091 KK = K1
16092 K1 = K2
16093 K2 = KK
16094 KS = -KS
16095 ELSE
16096 GOTO 990
16097 ENDIF
16098 ITER = ITER+1
16099C select method
16100 IF(ITER.GT.2) GOTO 230
16101
16102C conversion according to color flow method
16103 IFAI = 0
16104 DO 210 II=K1,K2-KS,KS
16105 DO 215 IK=II+KS,K2,KS
16106 XM1 = XML(II)
16107 XM2 = XML(IK)
16108* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16109* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16110 IF((ABS(XM1-XMP(II)).GT.DELM)
16111 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16112 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16113 IF(IREJ.NE.0) THEN
16114 IFAIL(36) = IFAIL(36)+1
16115 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16116 & 'PHO_PARCOR: ',
16117 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16118 & KEVENT,IMODE,II,IK
16119 IREJ = 0
16120 ELSE
16121 ICH = ICH+1
16122 DO 220 KK=1,4
16123 PL(KK,II) = PP1(KK)
16124 PL(KK,IK) = PP2(KK)
16125 220 CONTINUE
16126 XMP(II) = XM1
16127 XMP(IK) = XM2
16128 GOTO 219
16129 ENDIF
16130 ELSE
16131 GOTO 219
16132 ENDIF
16133 215 CONTINUE
16134 IFAI = II
16135 219 CONTINUE
16136 210 CONTINUE
16137 IF(IFAI.NE.0) GOTO 300
16138 GOTO 950
16139C
16140 230 CONTINUE
16141C
16142C conversion according to remainder method
16143 DO 350 I=K1,K2,KS
16144 XM1 = XML(I)
16145 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16146 ICH = ICH+1
16147 IFAI = I
16148C conversion necessary
16149 DO 400 K=1,4
16150 PB1(K) = PL(K,I)
16151 PB2(K) = PHEP(K,IMODE)-PB1(K)
16152 400 CONTINUE
16153 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16154 IF(XM2.LT.0.D0) THEN
16155 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16156 & 'PHO_PARCOR: ',
16157 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16158 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16159 GOTO 300
16160 ENDIF
16161 XM2 = SQRT(XM2)
16162 IF((XM1+XM2).GE.XMC) THEN
16163 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16164 & 'PHO_PARCOR: ',
16165 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16166 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16167 GOTO 300
16168 ENDIF
16169C conversion possible
16170 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16171 IF(IREJ.NE.0) THEN
16172 IFAIL(36) = IFAIL(36)+1
16173 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16174 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16175 & ITER,IMODE,I
16176 GOTO 300
16177 ENDIF
16178C calculate Lorentz transformation
16179 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16180 IF(IREJ.NE.0) THEN
16181 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16182 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16183 & ITER,IMODE,I
16184 GOTO 300
16185 ENDIF
16186 IFAI = 0
16187C transform remaining partons
16188 DO 450 L=K1,K2,KS
16189 IF(L.NE.I) THEN
16190 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16191 DO 500 K=1,4
16192 PL(K,L) = PP2(K)
16193 500 CONTINUE
16194 ELSE
16195 DO 550 K=1,4
16196 PL(K,L) = PP1(K)
16197 550 CONTINUE
16198 ENDIF
16199 450 CONTINUE
16200 XMP(I) = XM1
16201 ENDIF
16202 350 CONTINUE
16203 ENDIF
16204
16205C register transformed partons
16206 950 CONTINUE
16207 IREJ = 0
16208 IF(ICH.NE.0) THEN
16209 IP1 = NHEP+1
16210 L = 0
16211 DO 700 I=I1,I2
16212 L= L+1
16213 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16214 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16215 & ICOLOR(2,I),IPOS,1)
16216 700 CONTINUE
16217 IP2 = IPOS
16218C register string
16219 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16220 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16221 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16222C update /POSTRG/
16223 I = IPHIST(1,IMODE)
16224 NPOS(1,I) = IPOS
16225 NPOS(2,I) = IP1
16226 NPOS(3,I) = -IP2
16227 ENDIF
16228C debug output
16229 IF(IDEB(82).GE.20) THEN
16230 WRITE(LO,'(1X,A,I7,2I4)')
16231 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16232 & KEVENT,IMODE,L
16233 DO 850 I=1,L
16234 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16235 & XMP(I),XML(I)
16236 850 CONTINUE
16237 WRITE(LO,'(1X,A,2I5)')
16238 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16239 ENDIF
16240 RETURN
16241C rejection
16242 990 CONTINUE
16243 IREJ = 1
16244 IF(IDEB(82).GE.3) THEN
16245 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16246 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16247 & IFAI,IPAR,IMODE,XMC
16248 IF(IDEB(82).GE.5) THEN
16249 WRITE(LO,'(1X,A,I7,2I4)')
16250 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16251 & KEVENT,IMODE,IPAR
16252 DO 155 I=1,IPAR
16253 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16254 & XMP(I),XML(I)
16255 155 CONTINUE
16256 ENDIF
16257 ENDIF
16258 RETURN
16259
16260 ELSE IF(IMODE.EQ.-1) THEN
16261C initialization
16262 RETURN
16263
16264 ELSE IF(IMODE.EQ.-2) THEN
16265C final output
16266 RETURN
16267 ENDIF
16268 END
16269
16270*$ CREATE PHO_STRING.FOR
16271*COPY PHO_STRING
16272CDECK ID>, PHO_STRING
16273 SUBROUTINE PHO_STRING(IMODE,IREJ)
16274C********************************************************************
16275C
16276C calculation of string combinatorics, Lorentz boosts and
16277C particle codes
16278C
16279C - splitting of gluons
16280C - strings will be built up from pairs of partons
16281C according to their color labels
16282C with IDHEP(..) = -1
16283C - there can be other particles between to string partons
16284C (these will be unchanged by string construction)
16285C - string mass fine correction
16286C
16287C input: IMODE 1 complete string processing
16288C -1 initialization
16289C -2 output of statistics
16290C
16291C output: /POSTRG/
16292C IREJ 1 combination of strings impossible
16293C 0 successful combination
16294C 50 rejection due to user cutoffs
16295C
16296C********************************************************************
16297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16298 SAVE
16299
16300 PARAMETER ( DEPS = 1.D-15,
16301 & EPS = 1.D-5 )
16302
16303C input/output channels
16304 INTEGER LI,LO
16305 COMMON /POINOU/ LI,LO
16306C event debugging information
16307 INTEGER NMAXD
16308 PARAMETER (NMAXD=100)
16309 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16310 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16311 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16312 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16313C general process information
16314 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16315 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16316C internal rejection counters
16317 INTEGER NMXJ
16318 PARAMETER (NMXJ=60)
16319 CHARACTER*10 REJTIT
16320 INTEGER IFAIL
16321 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16322C model switches and parameters
16323 CHARACTER*8 MDLNA
16324 INTEGER ISWMDL,IPAMDL
16325 DOUBLE PRECISION PARMDL
16326 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16327C hard cross sections and MC selection weights
16328 INTEGER Max_pro_2
16329 PARAMETER ( Max_pro_2 = 16 )
16330 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16331 & MH_acc_1,MH_acc_2
16332 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16333 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16334 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16335 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16336 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16337 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16338C standard particle data interface
16339 INTEGER NMXHEP
16340 PARAMETER (NMXHEP=4000)
16341 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16342 DOUBLE PRECISION PHEP,VHEP
16343 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16344 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16345 & VHEP(4,NMXHEP)
16346C extension to standard particle data interface (PHOJET specific)
16347 INTEGER IMPART,IPHIST,ICOLOR
16348 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16349C color string configurations including collapsed strings and hadrons
16350 INTEGER MSTR
16351 PARAMETER (MSTR=500)
16352 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16353 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16354 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16355 & NNCH(MSTR),IBHAD(MSTR),ISTR
16356C table of particle indices for recursive PHOJET calls
16357 INTEGER MAXIPX
16358 PARAMETER ( MAXIPX = 100 )
16359 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16360 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16361 & IPOIX1,IPOIX2,IPOIX3
16362C some constants
16363 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16364 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16365 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16366
16367 IREJ = 0
16368 IF(IMODE.EQ.-1) THEN
16369 CALL PHO_POMCOR(-1)
16370 CALL PHO_MASCOR(-1)
16371 CALL PHO_PARCOR(-1,IREJ)
16372 RETURN
16373 ELSE IF(IMODE.EQ.-2) THEN
16374 CALL PHO_POMCOR(-2)
16375 CALL PHO_MASCOR(-2)
16376 CALL PHO_PARCOR(-2,IREJ)
16377 RETURN
16378 ENDIF
16379
16380C generate enhanced graphs
16381 IF(IPOIX2.GT.0) THEN
16382 200 CONTINUE
16383 I1 = MAX(1,IPOIX1)
16384 I2 = IPOIX2
16385 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16386 KSPOMS = KSPOM-1
16387 KSREGS = KSREG
16388 KHPOMS = KHPOM
16389 KHDIRS = KHDIR
16390 IDDFS1 = IDIFR1
16391 IDDFS2 = IDIFR2
16392 IDDPOS = IDDPOM
16393 DO 110 I=I1,I2
16394 IPOIX3 = I
16395 KSPOM = 0
16396 KSREG = 0
16397 KHPOM = 0
16398 KHDIR = 0
16399 IF(IPORES(I).EQ.8) THEN
16400 KSPOM = 2
16401 LSPOM = 2
16402 LHPOM = 0
16403 LSREG = 0
16404 LHDIR = 0
16405 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16406 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16407 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16408 IF(IREJ.NE.0) THEN
16409 IF(IDEB(4).GE.2) THEN
16410 WRITE(LO,'(/1X,A,I5)')
16411 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16412 CALL PHO_PREVNT(-1)
16413 ENDIF
16414 RETURN
16415 ENDIF
16416 KSPOM = KSPOMS+LSPOM
16417 KSREG = KSREGS+LSREG
16418 KHPOM = KHPOMS+LHPOM
16419 KHDIR = KHDIRS+LHDIR
16420 ELSE IF(IPORES(I).EQ.4) THEN
16421 ITEMP = ISWMDL(17)
16422 ISWMDL(17) = 0
16423 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16424 ISWMDL(17) = ITEMP
16425 IF(IREJ.NE.0) THEN
16426 IF(IDEB(4).GE.2) THEN
16427 WRITE(LO,'(/1X,A,I5)')
16428 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16429 CALL PHO_PREVNT(-1)
16430 ENDIF
16431 RETURN
16432 ENDIF
16433 KSDPO = KSDPO+1
16434 KSPOM = KSPOMS+KSPOM
16435 KSREG = KSREGS+KSREG
16436 KHPOM = KHPOMS+KHPOM
16437 KHDIR = KHDIRS+KHDIR
16438 ELSE
16439 IDIF1 = 1
16440 IDIF2 = 1
16441 IF(IPORES(I).EQ.5) THEN
16442 IDIF2 = 0
16443 KSTRG = KSTRG+1
16444 ELSE IF(IPORES(I).EQ.6) THEN
16445 IDIF1 = 0
16446 KSTRG = KSTRG+1
16447 ELSE
16448 KSLOO = KSLOO+1
16449 ENDIF
16450 ITEMP = ISWMDL(16)
16451 ISWMDL(16) = 0
16452 SPROB = 1.D0
16453 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16454 & 0,MSOFT,MHARD,IREJ)
16455 ISWMDL(16) = ITEMP
16456 IF(IREJ.NE.0) THEN
16457 IF(IDEB(4).GE.2) THEN
16458 WRITE(LO,'(/1X,A,I5)')
16459 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16460 CALL PHO_PREVNT(-1)
16461 ENDIF
16462 RETURN
16463 ENDIF
16464 KSPOM = KSPOMS+KSPOM
16465 KSREG = KSREGS+KSREG
16466 KHPOM = KHPOMS+KHPOM
16467 KHDIR = KHDIRS+KHDIR
16468 ENDIF
16469 IDIFR1 = IDDFS1
16470 IDIFR2 = IDDFS2
16471 IDDPOM = IDDPOS
16472 110 CONTINUE
16473 IF(IPOIX2.GT.I2) THEN
16474 IPOIX1 = I2+1
16475 GOTO 200
16476 ENDIF
16477 ENDIF
16478
16479C optional: split gluons to q-qbar pairs
16480 IF(ISWMDL(9).GT.0) THEN
16481 NHEPO = NHEP
16482 DO 30 I=3,NHEPO
16483 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16484 ICG1=ICOLOR(1,I)
16485 ICG2=ICOLOR(2,I)
16486 IQ1 = 0
16487 IQ2 = 0
16488 DO 40 K=3,NHEPO
16489 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16490 IQ1 = K
16491 IF(IQ1*IQ2.NE.0) GOTO 45
16492 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16493 IQ2 = K
16494 IF(IQ1*IQ2.NE.0) GOTO 45
16495 ENDIF
16496 40 CONTINUE
16497 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16498 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16499 CALL PHO_ABORT
16500 45 CONTINUE
16501 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16502 IF(IREJ.NE.0) THEN
16503 IF(IDEB(19).GE.5) THEN
16504 WRITE(LO,'(/,1X,A)')
16505 & 'PHO_STRING: no gluon splitting possible'
16506 CALL PHO_PREVNT(0)
16507 ENDIF
16508 RETURN
16509 ENDIF
16510 ENDIF
16511 30 CONTINUE
16512 ENDIF
16513
16514C construct strings and write entries sorted by strings
16515
16516 ISTR = ISTR+1
16517 NHEPO = NHEP
16518 DO 50 I=3,NHEPO
16519 IF(ISTR.GT.MSTR) THEN
16520 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16521 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16522 CALL PHO_PREVNT(0)
16523 IREJ = 1
16524 RETURN
16525 ENDIF
16526 IF(ISTHEP(I).EQ.1) THEN
16527C hadrons / resonances / clusters
16528 NPOS(1,ISTR) = I
16529 NPOS(2,ISTR) = 0
16530 NPOS(3,ISTR) = 0
16531 NPOS(4,ISTR) = abs(IPHIST(2,I))
16532 NCODE(ISTR) = -99
16533 IPHIST(1,I) = ISTR
16534 ISTR = ISTR+1
16535 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16536C quark /diquark terminated strings
16537 ICOL1 = -ICOLOR(1,I)
16538 P1 = PHEP(1,I)
16539 P2 = PHEP(2,I)
16540 P3 = PHEP(3,I)
16541 P4 = PHEP(4,I)
16542 ICH1 = IPHO_CHR3(I,2)
16543 IBA1 = IPHO_BAR3(I,2)
16544 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16545 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16546 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16547 JM1 = IPOS
16548
16549 NRPOM = 0
16550 65 CONTINUE
16551 DO 55 K=3,NHEPO
16552 IF(ISTHEP(K).EQ.-1)THEN
16553 IF(IDHEP(K).EQ.21) THEN
16554 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16555 ICOL1 = -ICOLOR(2,K)
16556 GOTO 60
16557 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16558 ICOL1 = -ICOLOR(1,K)
16559 GOTO 60
16560 ENDIF
16561 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16562 ICOL1 = 0
16563 GOTO 60
16564 ENDIF
16565 ENDIF
16566 55 CONTINUE
16567 WRITE(LO,'(/1X,A,I5)')
16568 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16569 CALL PHO_ABORT
16570 60 CONTINUE
16571 P1 = P1+PHEP(1,K)
16572 P2 = P2+PHEP(2,K)
16573 P3 = P3+PHEP(3,K)
16574 P4 = P4+PHEP(4,K)
16575 NRPOM = MAX(NRPOM,IPHIST(1,K))
16576 ICH1 = ICH1+IPHO_CHR3(K,2)
16577 IBA1 = IBA1+IPHO_BAR3(K,2)
16578 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16579 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16580 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16581C further parton involved?
16582 IF(ICOL1.NE.0) GOTO 65
16583 JM2 = IPOS
16584C register string
16585 IGEN = IPHIST(2,K)
16586 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16587 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16588C store additional string information
16589 NPOS(1,ISTR) = IPOS
16590 NPOS(2,ISTR) = JM1
16591 NPOS(3,ISTR) = -JM2
16592 NPOS(4,ISTR) = abs(IPHIST(2,K))
16593C calculate CPC string codes
16594 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16595 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16596 ISTR = ISTR+1
16597 ENDIF
16598 50 CONTINUE
16599
16600 DO 150 I=3,NHEPO
16601 IF(ISTR.GT.MSTR) THEN
16602 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16603 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16604 CALL PHO_PREVNT(0)
16605 IREJ = 1
16606 RETURN
16607 ENDIF
16608 IF(ISTHEP(I).EQ.-1) THEN
16609C gluon loop-strings
16610 ICOL1 = -ICOLOR(1,I)
16611 P1 = PHEP(1,I)
16612 P2 = PHEP(2,I)
16613 P3 = PHEP(3,I)
16614 P4 = PHEP(4,I)
16615 IBA1 = 0
16616 ICH1 = 0
16617 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16618 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16619 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16620 JM1 = IPOS
16621C
16622 NRPOM = 0
16623 165 CONTINUE
16624 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16625 DO 155 K=I,NHEPO
16626 IF(ISTHEP(K).EQ.-1)THEN
16627 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16628 ICOL1 = -ICOLOR(2,K)
16629 GOTO 160
16630 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16631 ICOL1 = -ICOLOR(1,K)
16632 GOTO 160
16633 ENDIF
16634 ENDIF
16635 155 CONTINUE
16636 WRITE(LO,'(/1X,A,I5)')
16637 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16638 CALL PHO_ABORT
16639 160 CONTINUE
16640 P1 = P1+PHEP(1,K)
16641 P2 = P2+PHEP(2,K)
16642 P3 = P3+PHEP(3,K)
16643 P4 = P4+PHEP(4,K)
16644 NRPOM = MAX(NRPOM,IPHIST(1,K))
16645 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16646 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16647 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16648C further parton involved?
16649 IF(ICOL1.NE.0) GOTO 165
16650 170 CONTINUE
16651 JM2 = IPOS
16652C register string
16653 IGEN = IPHIST(2,K)
16654 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16655 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16656C store additional string information
16657 NPOS(1,ISTR) = IPOS
16658 NPOS(2,ISTR) = JM1
16659 NPOS(3,ISTR) = -JM2
16660 NPOS(4,ISTR) = abs(IPHIST(2,K))
16661C calculate CPC string codes
16662 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16663 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16664 ISTR = ISTR+1
16665 ENDIF
16666 150 CONTINUE
16667
16668 ISTR = ISTR-1
16669
16670 IF(IDEB(19).GE.17) THEN
16671 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16672 CALL PHO_PREVNT(0)
16673 ENDIF
16674
16675C pomeron corrections
16676 CALL PHO_POMCOR(IREJ)
16677 IF(IREJ.NE.0) THEN
16678 IFAIL(38) = IFAIL(38)+1
16679 IF(IDEB(19).GE.3) THEN
16680 WRITE(LO,'(1X,A,I6)')
16681 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16682 CALL PHO_PREVNT(-1)
16683 ENDIF
16684 RETURN
16685 ENDIF
16686
16687C string mass corrections
16688 CALL PHO_MASCOR(IREJ)
16689 IF(IREJ.NE.0) THEN
16690 IFAIL(34) = IFAIL(34)+1
16691 IF(IDEB(19).GE.3) THEN
16692 WRITE(LO,'(1X,A,I6)')
16693 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16694 CALL PHO_PREVNT(-1)
16695 ENDIF
16696 RETURN
16697 ENDIF
16698
16699C parton mass corrections
16700 DO 100 I=1,ISTR
16701 IF(NCODE(I).GE.0) THEN
16702 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16703 IF(IREJ.NE.0) THEN
16704 IFAIL(35) = IFAIL(35)+1
16705 IF(IDEB(19).GE.3) THEN
16706 WRITE(LO,'(1X,A,I6)')
16707 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16708 CALL PHO_PREVNT(-1)
16709 ENDIF
16710 RETURN
16711 ENDIF
16712 ENDIF
16713 100 CONTINUE
16714
16715C statistics of hard processes
16716 DO 550 I=3,NHEP
16717 IF(ISTHEP(I).EQ.25) THEN
16718 K = IMPART(I)
16719 II = IDHEP(I)
16720 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16721 ENDIF
16722 550 CONTINUE
16723
16724C debug: write out strings
16725 IF(IDEB(19).GE.5) THEN
16726 IF(IDEB(19).GE.10)
16727 & CALL PHO_CHECK(1,IDEV)
16728 IF(IDEB(19).GE.15) THEN
16729 CALL PHO_PREVNT(0)
16730 ELSE
16731 CALL PHO_PRSTRG
16732 ENDIF
16733 ENDIF
16734
16735 END
16736
16737*$ CREATE PHO_STRFRA.FOR
16738*COPY PHO_STRFRA
16739CDECK ID>, PHO_STRFRA
16740 SUBROUTINE PHO_STRFRA(IREJ)
16741C********************************************************************
16742C
16743C do all fragmentation of strings
16744C
16745C output: IREJ 0 successful
16746C 1 rejection
16747C 50 rejection due to user cutoffs
16748C
16749C********************************************************************
16750 IMPLICIT NONE
16751 SAVE
16752
16753C input/output channels
16754 INTEGER LI,LO
16755 COMMON /POINOU/ LI,LO
16756C some constants
16757 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16758 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16759 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16760C event debugging information
16761 INTEGER NMAXD
16762 PARAMETER (NMAXD=100)
16763 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16764 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16765 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16766 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16767C general process information
16768 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16769 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16770C model switches and parameters
16771 CHARACTER*8 MDLNA
16772 INTEGER ISWMDL,IPAMDL
16773 DOUBLE PRECISION PARMDL
16774 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16775C global event kinematics and particle IDs
16776 INTEGER IFPAP,IFPAB
16777 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16778 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16779C standard particle data interface
16780 INTEGER NMXHEP
16781 PARAMETER (NMXHEP=4000)
16782 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16783 DOUBLE PRECISION PHEP,VHEP
16784 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16785 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16786 & VHEP(4,NMXHEP)
16787C extension to standard particle data interface (PHOJET specific)
16788 INTEGER IMPART,IPHIST,ICOLOR
16789 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16790C color string configurations including collapsed strings and hadrons
16791 INTEGER MSTR
16792 PARAMETER (MSTR=500)
16793 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16794 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16795 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16796 & NNCH(MSTR),IBHAD(MSTR),ISTR
16797
16798 INTEGER IREJ
16799
16800 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16801 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16802 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16803
16804 integer indx(500),indx_max
16805
16806 DOUBLE PRECISION DT_RNDM
16807 INTEGER ipho_pdg2id
16808 EXTERNAL DT_RNDM,ipho_pdg2id
16809
16810 DOUBLE PRECISION PYP,RQLUN
16811 INTEGER PYK
16812
16813 INTEGER MSTU,MSTJ
16814 DOUBLE PRECISION PARU,PARJ
16815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16816 INTEGER N,NPAD,K
16817 DOUBLE PRECISION P,V
16818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16819
16820 DIMENSION IJOIN(100)
16821
16822 IREJ = 0
16823 IF(ABS(ISWMDL(6)).GT.3) THEN
16824 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16825 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16826 CALL PHO_ABORT
16827 ENDIF
16828
16829C popcorn suppression
16830 IF(PARMDL(134).GT.0.D0) THEN
16831 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16832 MSTJ(12) = 2
16833 ELSE
16834 MSTJ(12) = 1
16835 ENDIF
16836 ENDIF
16837
16838C copy partons to fragmentation code JETSET
16839 IP = 0
16840 IP_old = 1
16841
16842 DO 300 J=1,ISTR
16843
16844C select partons with common production process
16845 IGEN = NPOS(4,J)
16846 if(IGEN.lt.0) goto 299
16847
16848 indx_max = 0
16849 DO 400 I=J,ISTR
16850 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16851
16852C write final particles/resonances to JETSET
16853 IF(NCODE(I).EQ.-99) THEN
16854 II = NPOS(1,I)
16855 IP = IP+1
16856 P(IP,1) = PHEP(1,II)
16857 P(IP,2) = PHEP(2,II)
16858 P(IP,3) = PHEP(3,II)
16859 P(IP,4) = PHEP(4,II)
16860 P(IP,5) = PHEP(5,II)
16861 K(IP,1) = 1
16862 K(IP,2) = IDHEP(II)
16863 K(IP,3) = 0
16864 K(IP,4) = 0
16865 K(IP,5) = 0
16866 IPHIST(2,II) = IP
16867 if(indx_max.eq.500) then
16868 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16869 & 'no space left in index vector (indx,Kevent)',
16870 & indx_max,KEVENT
16871 IREJ = 1
16872 return
16873 endif
16874 indx_max = indx_max+1
16875 indx(indx_max) = II
16876C write partons to JETSET
16877 ELSE IF(NCODE(I).GE.0) THEN
16878 K1 = JMOHEP(1,NPOS(1,I))
16879 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16880 IJ = 0
16881 DO II=K1,K2
16882 IP = IP+1
16883 P(IP,1) = PHEP(1,II)
16884 P(IP,2) = PHEP(2,II)
16885 P(IP,3) = PHEP(3,II)
16886 P(IP,4) = PHEP(4,II)
16887 P(IP,5) = PHEP(5,II)
16888 K(IP,1) = 1
16889 K(IP,2) = IDHEP(II)
16890 K(IP,3) = 0
16891 K(IP,4) = 0
16892 K(IP,5) = 0
16893 IPHIST(2,II) = IP
16894 IJ = IJ+1
16895 IJOIN(IJ) = IP
16896 indx_max = indx_max+1
16897 indx(indx_max) = II
16898 ENDDO
16899 II = JMOHEP(2,NPOS(1,I))
16900 IF((II.GT.0).AND.(II.NE.K1)) THEN
16901 IP = IP+1
16902 P(IP,1) = PHEP(1,II)
16903 P(IP,2) = PHEP(2,II)
16904 P(IP,3) = PHEP(3,II)
16905 P(IP,4) = PHEP(4,II)
16906 P(IP,5) = PHEP(5,II)
16907 K(IP,1) = 1
16908 K(IP,2) = IDHEP(II)
16909 K(IP,3) = 0
16910 K(IP,4) = 0
16911 K(IP,5) = 0
16912 IPHIST(2,II) = IP
16913 IJ = IJ+1
16914 IJOIN(IJ) = IP
16915 indx_max = indx_max+1
16916 indx(indx_max) = II
16917 ENDIF
16918 N = IP
16919C connect partons to strings
16920 CALL PYJOIN(IJ,IJOIN)
16921 ENDIF
16922
16923 NPOS(4,I) = -NPOS(4,I)
16924 endif
16925 400 continue
16926
16927C set Lund counter
16928 N = IP
16929 if(IP.eq.0) goto 299
16930
16931C hard final state evolution
16932 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16933 ISH = 0
16934 do 125 k1=1,indx_max
16935 I = indx(k1)
16936 IF(IPHIST(1,I).LE.-100) THEN
16937 ISH = ISH+1
16938 IJOIN(ISH) = I
16939 ENDIF
16940 125 continue
16941 IF(ISH.GE.2) THEN
16942 DO 130 K1=1,ISH
16943 IF(IJOIN(K1).EQ.0) GOTO 130
16944 I = IJOIN(K1)
16945 IF((IPAMDL(102).EQ.1)
16946 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16947 DO 135 K2=K1+1,ISH
16948 IF(IJOIN(K2).EQ.0) GOTO 135
16949 II = IJOIN(K2)
16950 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16951 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16952 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16953 RQLUN = MIN(PT1,PT2)
16954 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16955 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16956 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16957 IJOIN(K1) = 0
16958 IJOIN(K2) = 0
16959 GOTO 130
16960 ENDIF
16961 135 CONTINUE
16962 130 CONTINUE
16963 ENDIF
16964 ENDIF
16965
16966C fragment parton / hadron configuration (hadronization & decay)
16967
16968 IF(ISWMDL(6).NE.0) THEN
16969 II = MSTU(21)
16970 MSTU(21) = 1
16971 CALL PYEXEC
16972 MSTU(21) = II
16973C Lund warning?
16974 if(MSTU(28).ne.0) then
16975 IF(IDEB(22).GE.10) THEN
16976 WRITE(LO,'(1X,A,I12,I3)')
16977 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
16978 & KEVENT,MSTU(28)
16979 CALL PHO_PREVNT(2)
16980 ENDIF
16981 endif
16982C event accepted?
16983 IF(MSTU(24).NE.0) THEN
16984 IF(IDEB(22).GE.2) THEN
16985 WRITE(LO,'(1X,A,I12,I3)')
16986 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
16987 & KEVENT,MSTU(24)
16988 CALL PHO_PREVNT(2)
16989 ENDIF
16990 IREJ = 1
16991 RETURN
16992 ENDIF
16993 ENDIF
16994
16995 IP = N
16996C change particle status in JETSET to avoid internal adjustments
16997 do k1=IP_old,IP
16998 K(k1,1) = K(k1,1)+1000
16999 enddo
17000 IP_old = IP+1
17001
17002 299 continue
17003 300 CONTINUE
17004
17005C restore original JETSET particle status codes
17006 do i=1,N
17007 K(i,1) = K(i,1)-1000
17008 enddo
17009
17010* IF(IDEB(22).GE.25) THEN
17011* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17012* & 'particle/string system before fragmentation'
17013* CALL PHO_PREVNT(2)
17014* ENDIF
17015
17016C copy hadrons back to POEVT1 / POEVT2
17017
17018 IF(IP.GT.0) THEN
17019 NHEP1 = NHEP+1
17020 NLINES = PYK(0,1)
17021C copy hadrons back with full history information
17022 IF(IPAMDL(178).EQ.1) THEN
17023 DO 155 II=1,ISTR
17024 IF(NCODE(II).GE.0) THEN
17025 K1 = IPHIST(2,NPOS(2,II))
17026 K2 = IPHIST(2,-NPOS(3,II))
17027 ELSE IF(NCODE(II).EQ.-99) THEN
17028 K1 = IPHIST(2,NPOS(1,II))
17029 K2 = K1
17030 ELSE
17031 GOTO 149
17032 ENDIF
17033 IFOUND = 0
17034 DO 160 J=1,NLINES
17035 IF(PYK(J,7).EQ.1) THEN
17036 IPMOTH = PYK(J,15)
17037 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17038 IBAM = ipho_pdg2id(PYK(J,8))
17039 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17040 IF(IDEB(22).GE.2) THEN
17041 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17042 & 'LUND interface (1) rejection'
17043 CALL PHO_PREVNT(2)
17044 ENDIF
17045 IREJ = 1
17046 RETURN
17047 ENDIF
17048 IFOUND = IFOUND+1
17049 PX = PYP(J,1)
17050 PY = PYP(J,2)
17051 PZ = PYP(J,3)
17052 HE = PYP(J,4)
17053 XMB = PYP(J,5)**2
17054C register parton/hadron
17055 IS = 1
17056 IF(IBAM.EQ.0) THEN
17057 IF(ISWMDL(6).EQ.0) THEN
17058 IS = -1
17059 ELSE
17060 IF(IDEB(22).GE.2) THEN
17061 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17062 & 'LUND interface (2) rejection'
17063 CALL PHO_PREVNT(2)
17064 ENDIF
17065 IREJ = 1
17066 RETURN
17067 ENDIF
17068 ENDIF
17069 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17070 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17071 ISTHEP(IPOS) = 1
17072 ENDIF
17073 ENDIF
17074 160 CONTINUE
17075 IF(IFOUND.EQ.0) THEN
17076 IF(IDEB(2).GE.2) THEN
17077 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17078 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17079 ENDIF
17080 ISTHEP(NPOS(1,II)) = 2
17081 ENDIF
17082 149 CONTINUE
17083 155 CONTINUE
17084 ELSE
17085C copy hadrons back without history information
17086 JDAHEP(1,1) = NHEP1
17087 JDAHEP(1,2) = NHEP1
17088 DO 170 J=1,NLINES
17089 IF(PYK(J,7).EQ.1) THEN
17090 IBAM = ipho_pdg2id(PYK(J,8))
17091 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17092 IF(IDEB(22).GE.2) THEN
17093 WRITE(LO,'(/1X,A)')
17094 & 'PHO_STRFRA: LUND interface (3) rejection'
17095 CALL PHO_PREVNT(2)
17096 ENDIF
17097 IREJ = 1
17098 RETURN
17099 ENDIF
17100 PX = PYP(J,1)
17101 PY = PYP(J,2)
17102 PZ = PYP(J,3)
17103 HE = PYP(J,4)
17104 XMB = PYP(J,5)**2
17105C register parton/hadron
17106 IS = 1
17107 IF(IBAM.EQ.0) THEN
17108 IF(ISWMDL(6).EQ.0) THEN
17109 IS = -1
17110 ELSE
17111 IF(IDEB(22).GE.2) THEN
17112 WRITE(LO,'(/1X,A)')
17113 & 'PHO_STRFRA: LUND interface (4) rejection'
17114 CALL PHO_PREVNT(2)
17115 ENDIF
17116 IREJ = 1
17117 RETURN
17118 ENDIF
17119 ENDIF
17120 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17121 & HE,J,0,0,0,IPOS,1)
17122 ISTHEP(IPOS) = 1
17123 ENDIF
17124 170 CONTINUE
17125 DO 180 II=1,ISTR
17126 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17127 & ISTHEP(NPOS(1,II)) = 2
17128 180 CONTINUE
17129 ENDIF
17130 ENDIF
17131
17132C debug event status
17133 IF(IDEB(22).GE.15) THEN
17134 WRITE(LO,'(//1X,A)')
17135 & 'PHO_STRFRA: particle system after fragmentation'
17136 CALL PHO_PREVNT(2)
17137 ENDIF
17138
17139 END
17140
17141*$ CREATE PHO_EVEINI.FOR
17142*COPY PHO_EVEINI
17143CDECK ID>, PHO_EVEINI
17144 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17145C********************************************************************
17146C
17147C prepare /POEVT1/ for new event
17148C
17149C first subroutine called for each event
17150C
17151C input: P1(4) particle 1
17152C P2(4) particle 2
17153C IMODE 0 general initialization
17154C 1 initialization of particles and kinematics
17155C 2 initialization after internal rejection
17156C
17157C output: IP1,IP2 index of interacting particles
17158C
17159C********************************************************************
17160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17161 SAVE
17162
17163 DIMENSION P1(4),P2(4)
17164
17165 PARAMETER ( EPS = 1.D-5,
17166 & DEPS = 1.D-15 )
17167
17168C input/output channels
17169 INTEGER LI,LO
17170 COMMON /POINOU/ LI,LO
17171C event debugging information
17172 INTEGER NMAXD
17173 PARAMETER (NMAXD=100)
17174 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17175 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17176 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17177 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17178C model switches and parameters
17179 CHARACTER*8 MDLNA
17180 INTEGER ISWMDL,IPAMDL
17181 DOUBLE PRECISION PARMDL
17182 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17183C general process information
17184 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17185 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17186C gamma-lepton or gamma-hadron vertex information
17187 INTEGER IGHEL,IDPSRC,IDBSRC
17188 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17189 & RADSRC,AMSRC,GAMSRC
17190 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17191 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17192 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17193C global event kinematics and particle IDs
17194 INTEGER IFPAP,IFPAB
17195 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17196 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17197C energy-interpolation table
17198 INTEGER IEETA2
17199 PARAMETER ( IEETA2 = 20 )
17200 INTEGER ISIMAX
17201 DOUBLE PRECISION SIGTAB,SIGECM
17202 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17203C cross sections
17204 INTEGER IPFIL,IFAFIL,IFBFIL
17205 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17206 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17207 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17208 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17209 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17210 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17211 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17212 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17213 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17214 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17215 & IPFIL,IFAFIL,IFBFIL
17216C color string configurations including collapsed strings and hadrons
17217 INTEGER MSTR
17218 PARAMETER (MSTR=500)
17219 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17220 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17221 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17222 & NNCH(MSTR),IBHAD(MSTR),ISTR
17223C standard particle data interface
17224 INTEGER NMXHEP
17225 PARAMETER (NMXHEP=4000)
17226 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17227 DOUBLE PRECISION PHEP,VHEP
17228 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17229 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17230 & VHEP(4,NMXHEP)
17231C extension to standard particle data interface (PHOJET specific)
17232 INTEGER IMPART,IPHIST,ICOLOR
17233 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17234C table of particle indices for recursive PHOJET calls
17235 INTEGER MAXIPX
17236 PARAMETER ( MAXIPX = 100 )
17237 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17238 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17239 & IPOIX1,IPOIX2,IPOIX3
17240C event weights and generated cross section
17241 INTEGER IPOWGC,ISWCUT,IVWGHT
17242 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17243 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17244 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17245
17246 DIMENSION IM(2)
17247
17248C reset debug variables
17249 KSPOM = 0
17250 KHPOM = 0
17251 KSREG = 0
17252 KHDIR = 0
17253 KSTRG = 0
17254 KHTRG = 0
17255 KSLOO = 0
17256 KHLOO = 0
17257 KSDPO = 0
17258 KSOFT = 0
17259 KHARD = 0
17260C
17261 IDNODF = 0
17262 IDIFR1 = 0
17263 IDIFR2 = 0
17264 IDDPOM = 0
17265 ISTR = 0
17266 IPOIX1 = 0
17267 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17268 IPOIX2 = 0
17269 IPOIX3 = 0
17270C reset /POEVT1/ and /POEVT2/
17271 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17272 & 0,0,0,0,IPOS,0)
17273 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17274 DO 15 I=0,10
17275 IPOWGC(I) = 0
17276 15 CONTINUE
17277
17278C initialization of particle kinematics
17279
17280C lepton-photon/hadron-photon vertex and initial particles
17281 IM(1) = 0
17282 IM(2) = 0
17283 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17284 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17285 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17286 ELSE
17287 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17288 & P1(4),0,0,0,0,IP1,1)
17289 ENDIF
17290 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17291 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17292 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17293 ELSE
17294 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17295 & P2(4),0,0,0,0,IP2,1)
17296 ENDIF
17297 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17298 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17299 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17300 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17301 & P1(4),0,0,0,0,IP1,1)
17302 ENDIF
17303 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17304 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17305 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17306 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17307 & P2(4),0,0,0,0,IP2,1)
17308 ENDIF
17309 NEVHEP = KACCEP
17310
17311 IF(IMODE.LE.1) THEN
17312C CMS energy
17313 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17314 & -(P1(3)+P2(3))**2)
17315* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17316 PMASS(1) = PHEP(5,IP1)
17317 PVIRT(1) = 0.D0
17318 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17319 PMASS(2) = PHEP(5,IP2)
17320 PVIRT(2) = 0.D0
17321 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17322 ENDIF
17323
17324C cross section calculations
17325
17326 IF(IMODE.NE.1) THEN
17327 IP = 1
17328 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17329 & ECM,PVIRT(1),PVIRT(2))
17330 ENDIF
17331
17332 IF(IMODE.LE.0) THEN
17333C effective cross section
17334 SIGGEN(3) = 0.D0
17335 IF(ISWMDL(2).ge.1) THEN
17336 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17337 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17338 & -SIGHDD-SIGDIR
17339 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17340 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17341 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17342 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17343 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17344 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17345 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17346C simulate only hard scatterings
17347 ELSE
17348 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17349 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17350 ENDIF
17351
17352 ENDIF
17353
17354C reset of mother/daughter relations only (IMODE = 2)
17355
17356C debug output
17357 IF(IDEB(63).GE.15) THEN
17358 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17359 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17360 IF(IMODE.LE.0) THEN
17361 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17362 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17363 & FSUP,FSUH,FSUD
17364 ONEM = -1.D0
17365 ITMP = IDEB(57)
17366 IDEB(57) = MAX(5,ITMP)
17367 CALL PHO_XSECT(1,0,ONEM)
17368 IDEB(57) = ITMP
17369 ENDIF
17370 CALL PHO_PREVNT(0)
17371 ENDIF
17372
17373 END
17374
17375*$ CREATE PHO_CSINT.FOR
17376*COPY PHO_CSINT
17377CDECK ID>, PHO_CSINT
17378 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17379C********************************************************************
17380C
17381C calculate cross sections by interpolation
17382C
17383C input: IP particle combination
17384C IFPA/B particle PDG number
17385C IHLA/B particle helicity (photons only)
17386C ECM c.m. energy (GeV)
17387C PVIR2A virtuality of particle A (GeV**2, positive)
17388C PVIR2B virtuality of particle B (GeV**2, positive)
17389C
17390C output: cross sections stored in /POCSEC/
17391C
17392C********************************************************************
17393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17394 SAVE
17395
17396 PARAMETER ( EPS = 1.D-5,
17397 & DEPS = 1.D-15 )
17398
17399C input/output channels
17400 INTEGER LI,LO
17401 COMMON /POINOU/ LI,LO
17402C some constants
17403 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17404 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17405 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17406C event debugging information
17407 INTEGER NMAXD
17408 PARAMETER (NMAXD=100)
17409 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17410 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17411 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17412 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17413C model switches and parameters
17414 CHARACTER*8 MDLNA
17415 INTEGER ISWMDL,IPAMDL
17416 DOUBLE PRECISION PARMDL
17417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17418C energy-interpolation table
17419 INTEGER IEETA2
17420 PARAMETER ( IEETA2 = 20 )
17421 INTEGER ISIMAX
17422 DOUBLE PRECISION SIGTAB,SIGECM
17423 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17424C cross sections
17425 INTEGER IPFIL,IFAFIL,IFBFIL
17426 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17427 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17428 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17429 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17430 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17431 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17432 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17433 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17434 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17435 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17436 & IPFIL,IFAFIL,IFBFIL
17437C hard cross sections and MC selection weights
17438 INTEGER Max_pro_2
17439 PARAMETER ( Max_pro_2 = 16 )
17440 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17441 & MH_acc_1,MH_acc_2
17442 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17443 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17444 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17445 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17446 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17447 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17448
17449 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17450
17451 dimension PD(-6:6),FH_T(2),FH_L(2)
17452
17453C debug
17454 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17455 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17456 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17457
17458C check currently stored cross sections
17459 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17460 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17461 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17462C nothing to calculate
17463 IF(IDEB(15).GE.20)
17464 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17465 RETURN
17466 ELSE
17467
17468C copy to local fields
17469 IFPAP(1) = IFPA
17470 IFPAP(2) = IFPB
17471 IHEL(1) = IHLA
17472 IHEL(2) = IHLB
17473 PVIRT(1) = PVIR2A
17474 PVIRT(2) = PVIR2B
17475
17476C load cross sections from interpolation table
17477 IF(ECM.LE.SIGECM(IP,1)) THEN
17478 I1 = 1
17479 I2 = 2
17480 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17481 DO 50 I=2,ISIMAX
17482 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17483 50 CONTINUE
17484 200 CONTINUE
17485 I1 = I-1
17486 I2 = I
17487 ELSE
17488 WRITE(LO,'(/1X,A,2E12.3)')
17489 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17490 CALL PHO_PREVNT(-1)
17491 I1 = ISIMAX-1
17492 I2 = ISIMAX
17493 ENDIF
17494 FAC2=0.D0
17495 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17496 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17497 FAC1=1.D0-FAC2
17498
17499C cross section dependence on photon virtualities
17500 DO 140 K=1,2
17501 FSUP(K) = 1.D0
17502 FSUD(K) = 1.D0
17503 FSUH(K) = 1.D0
17504 IF(IFPAP(K).EQ.22) THEN
17505 IF(ISWMDL(10).GE.1) THEN
17506 FSUP(K) = 0.D0
17507 FSUT(K) = 0.D0
17508 FSUL(K) = 0.D0
17509 FSUH(K) = 0.D0
17510C GVDM factors for transverse/longitudinal photons
17511 DO 150 I=1,3
17512 FSUT(K) = FSUT(K)+PARMDL(26+I)
17513 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17514 FSUL(K) = FSUL(K)
17515 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17516 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17517 150 CONTINUE
17518 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17519C transverse part
17520 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17521 FSUP(K) = FSUT(K)
17522 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17523C diffraction of trans. photons corresponds mainly to leading twist
17524 FSUD(K) = 1.D0
17525 ENDIF
17526C longitudinal (scalar) part
17527 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17528 FSUP(K) = FSUP(K)+FSUL(K)
17529 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17530C diffraction of long. photons corresponds mainly to higher twist
17531 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17532 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17533 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17534 ENDIF
17535C debug output
17536 if(ideb(15).ge.10) then
17537 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17538 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17539 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17540 endif
17541 ENDIF
17542 ENDIF
17543 140 CONTINUE
17544
17545 FACP = FSUP(1)*FSUP(2)
17546 FACH = FSUH(1)*FSUH(2)
17547 FACD = FSUD(1)*FSUD(2)
17548
17549C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17550
17551 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17552 & .and.(IPAMDL(117).gt.0)) then
17553C check kinematic limit
17554 Q2_max = max(PVIRT(1),PVIRT(2))
17555 Q2_min = min(PVIRT(1),PVIRT(2))
17556 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17557
17558C calculate F2 from current parton density
17559 if(PVIRT(1).gt.PVIRT(2)) then
17560 K = 2
17561 else
17562 K = 1
17563 endif
17564 Q2 = Q2_max
17565 P2 = Q2_min
17566 X = Q2/(ECM**2+Q2+P2)
17567 call pho_actpdf(IFPAP(K),K)
17568 call pho_pdf(K,X,Q2,P2,PD)
17569C light quark contribution
17570 F2_light = 0.D0
17571 do j=1,3
17572 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17573 enddo
17574C heavy quark contribution
17575 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17576 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17577 F2 = (F2_light+F2_c)
17578
17579C calculate model prediction
17580 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17581 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17582 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17583
17584 if(ISWMDL(10).ge.2) then
17585
17586C calculate all helicity combinations
17587 if(IPAMDL(115).eq.0) then
17588 SIGDIH = HSig(14)
17589 SIGSRH(1) = HSig(10)+HSig(11)
17590 SIGSRH(2) = HSig(12)+HSig(13)
17591 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17592C photon helicity factors
17593 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17594 FH_L(1) = 1.D0-FH_T(1)
17595 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17596 FH_L(2) = 1.D0-FH_T(2)
17597 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17598 & + SIGDIH*FH_T(1)*FH_T(2)
17599 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17600 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17601 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17602 & + SIGDIH*FH_T(1)*FH_L(2)
17603 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17604 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17605 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17606 & + SIGDIH*FH_L(1)*FH_T(2)
17607 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17608 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17609 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17610 & + SIGDIH*FH_L(1)*FH_L(2)
17611 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17612 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17613 else
17614C use explicit PDF virtuality dependence (pre-tabulated)
17615 SIGDIH = HSig(14)
17616 SIGSRH(1) = HSig(10)+HSig(11)
17617 SIGSRH(2) = HSig(12)+HSig(13)
17618 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
ecf67adb 17619 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
9aaba0d6 17620 stop
17621* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17622* & Max_pro_2,3,4,1)
17623* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17624* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17625* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17626* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17627* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17629* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17630* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17631 endif
17632 Xnu = Ecm*Ecm+Q2+P2
17633 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17634 & *137.D0/GeV2mb
17635 if(K.eq.2) then
17636 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17637 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17638 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17639 else
17640 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17641 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17642 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17643 endif
17644
17645 else
17646
17647C assume sig_eff = sigtot
17648 SIGDIH = HSig(14)
17649 SIGSRH(1) = HSig(10)+HSig(11)
17650 SIGSRH(2) = HSig(12)+HSig(13)
17651 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17652 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17653 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17654 Xnu = Ecm*Ecm+Q2+P2
17655 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17656 & *137.D0/GeV2mb
17657 F2m = F2_fac*SIGeff
17658 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17659 endif
ecf67adb 17660* WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17661* WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
9aaba0d6 17662
17663C global factor to re-scale suppression of soft contributions
17664 Fcorr = (F2-F2m+F2s)/F2s
ecf67adb 17665* WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
9aaba0d6 17666 FACP = FACP*Fcorr
17667
17668 endif
17669 endif
17670
17671 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17672 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17673 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17674 J = 2
17675 DO 5 I=0,4
17676 DO 6 K=0,4
17677 J = J+1
17678 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17679 & *FACP**2
17680 6 CONTINUE
17681 5 CONTINUE
17682
17683 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17684 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17685C suppression of multi-pomeron graphs (diffraction)
17686 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17687 & *FACP*FSUP(2)*FSUD(1)
17688 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17689 & *FACP*FSUP(1)*FSUD(2)
17690 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17691 & *FACP*FSUP(2)*FSUD(1)
17692 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17693 & *FACP*FSUP(1)*FSUD(2)
17694 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17695 & *FACP**2*FACD
17696 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17697 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17698 & *FACP**2
17699 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17700 & *FACP*FSUP(2)*FSUD(1)
17701 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17702 & *FACP*FSUP(2)*FSUD(1)
17703 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17704 & *FACP*FSUP(1)*FSUD(2)
17705 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17706 & *FACP*FSUP(1)*FSUD(2)
17707 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17708 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17709 & *FACP**2
17710 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17711 & *FACP**2
17712 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17713 & *FACP**2
17714 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17715 & *FACP**2
17716
17717C corrections due to photon virtuality dependence of PDFs
17718 if(iswmdl(2).eq.1) then
17719 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17720C minimum bias event generation
17721 IF(IPAMDL(115).GE.1) THEN
17722C all the virtuality dependence is given by PDF parametrization
17723 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17724 IF(IPAMDL(116).GE.2) THEN
17725C direct interaction according to full QPM calculation
17726 SIGDIH = HSig(14)
17727 SIGSRH(1) = HSig(10)+HSig(11)
17728 SIGSRH(2) = HSig(12)+HSig(13)
17729 ELSE
17730C direct interaction suppressed according to helicity factor
17731 SIGDIH = HSig(14)*FACH
17732 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17733 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17734 ENDIF
ecf67adb 17735 WRITE(LO,*) ' PHO_CSINT: option not supported yet'
9aaba0d6 17736 stop
17737 ELSE
17738C rescale relevant hard processes
17739 SIGDIH = HSig(14)
17740 SIGSRH(1) = HSig(10)+HSig(11)
17741 SIGSRH(2) = HSig(12)+HSig(13)
17742 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17743 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17744 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17745 SIGINE = SIGtmp+SIGDIR
17746 SIGTOT = SIGINE+SIGELA
17747 ENDIF
17748 else
17749C only hard interactions
17750 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17751 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17752 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17753 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17754 SIGHAR = HSig(9)*FACH
17755 endif
17756
17757 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17758 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17759 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17760 J = 39
17761 DO 9 I=1,4
17762 DO 10 K=1,4
17763 J = J+1
17764 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17765 10 CONTINUE
17766 9 CONTINUE
17767 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17768 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17769
17770 IPFIL = IP
17771 IFAFIL = IFPA
17772 IFBFIL = IFPB
17773 ECMFIL = ECM
17774 P2AFIL = PVIR2A
17775 P2BFIL = PVIR2B
17776
17777 IF(IDEB(15).GE.20)
17778 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17779
17780 ENDIF
17781
17782 END
17783
17784*$ CREATE PHO_PRIMKT.FOR
17785*COPY PHO_PRIMKT
17786CDECK ID>, PHO_PRIMKT
17787 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17788C***********************************************************************
17789C
17790C give primordial kt to partons entering hard scatterings and
17791C remants connected to hard parton-parton interactions by color flow
17792C
17793C input: IMODE -2 output of statistics
17794C -1 initialization
17795C 1 sampling of primordial kt
17796C IF first entry in /POEVT1/ to check
17797C IL last entry in /POEVT1/ to check
17798C PTCUT current value of PTCUT to distinguish
17799C between soft and hard
17800C
17801C output: IREJ 0 success
17802C 1 failure
17803C
17804C***********************************************************************
17805 IMPLICIT NONE
17806 SAVE
17807
17808 DOUBLE PRECISION DEPS
17809 PARAMETER ( DEPS = 1.D-15 )
17810
17811 INTEGER IMODE,IF,IL,IREJ
17812 DOUBLE PRECISION PTCUT
17813
17814C input/output channels
17815 INTEGER LI,LO
17816 COMMON /POINOU/ LI,LO
17817C event debugging information
17818 INTEGER NMAXD
17819 PARAMETER (NMAXD=100)
17820 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17821 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17822 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17823 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17824C model switches and parameters
17825 CHARACTER*8 MDLNA
17826 INTEGER ISWMDL,IPAMDL
17827 DOUBLE PRECISION PARMDL
17828 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17829C some constants
17830 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17831 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17832 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17833C data of c.m. system of Pomeron / Reggeon exchange
17834 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17835 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17836 & SIDP,CODP,SIFP,COFP
17837 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17838 & SIDP,CODP,SIFP,COFP,NPOSP(2),
17839 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
17840C hard scattering data
17841 INTEGER MSCAHD
17842 PARAMETER ( MSCAHD = 50 )
17843 INTEGER LSCAHD,LSC1HD,LSIDX,
17844 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17845 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17846 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17847 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17848 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17849 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17850 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17851 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17852 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17853C standard particle data interface
17854 INTEGER NMXHEP
17855 PARAMETER (NMXHEP=4000)
17856 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17857 DOUBLE PRECISION PHEP,VHEP
17858 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17859 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17860 & VHEP(4,NMXHEP)
17861C extension to standard particle data interface (PHOJET specific)
17862 INTEGER IMPART,IPHIST,ICOLOR
17863 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17864
17865 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17866 DIMENSION PTS(0:2,5),XP(5),
17867 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17868
17869 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17870
17871 PARAMETER (IRMAX=200)
17872 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17873
17874 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17875 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17876 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17877
17878C debug output
17879 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17880 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17881 & IMODE,IF,IL,PTCUT
17882
17883C give primordial kt to partons engaged in a hard scattering
17884
17885 IF(IMODE.EQ.1) THEN
17886
17887 ISTART = IF
17888
17889 100 CONTINUE
17890
17891 NHD = 0
17892 IBAL(1) = 0
17893 IBAL(2) = 0
17894 IROT = 0
17895 ICOM = 0
17896 DO 110 I=ISTART,IL
17897 IF(ISTHEP(I).EQ.25) THEN
17898C hard scattering number
17899 NHD = IPHIST(1,I+1)
17900 ICOM = I
17901 K = LSIDX(NHD/100)
17902C calculate momenta of incoming partons
17903 POLD(1,1) = XHD(K,1)*ECMP/2.D0
17904 POLD(2,1) = POLD(1,1)
17905 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17906 POLD(2,2) = -POLD(1,2)
17907 ISTART = I+3
17908 GOTO 150
17909 ENDIF
17910 110 CONTINUE
17911 RETURN
17912
17913 150 CONTINUE
17914
17915C search for partons involved in hard interaction
17916 INEXT = 0
17917 IROT = 0
17918 DO 500 I=ISTART,IL
17919 IF(ABS(ISTHEP(I)).EQ.1) THEN
17920C hard scatterd partons (including ISR)
17921 IF((IPHIST(1,I).EQ.-NHD)
17922 & .OR.(IPHIST(1,I).EQ.NHD+1)
17923 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17924 IROT = IROT+1
17925 IF(IROT.GT.IRMAX) THEN
17926 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17927 & 'no memory left in IROTT, event rejected (max/IROT)',
17928 & IRMAX,IROT
17929 CALL PHO_PREVNT(0)
17930 IREJ = 1
17931 RETURN
17932 ENDIF
17933 IROTT(IROT) = I
17934C hard remnant
17935 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17936 IF(PHEP(3,I).GT.0.D0) THEN
17937 J = 1
17938 ELSE
17939 J = 2
17940 ENDIF
17941 IBAL(J) = IBAL(J)+1
17942 IBALT(IBAL(J),J) = I
17943 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17944 IF(ISWMDL(24).EQ.0) THEN
17945 IV2(IBAL(J),J) = 0
17946 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17947 ELSE IF(ISWMDL(24).EQ.1) THEN
17948 IV2(IBAL(J),J) = -1
17949 ELSE
17950 IV2(IBAL(J),J) = 1
17951 ENDIF
17952 ENDIF
17953C possibly further hard scattering
17954 ELSE IF(ISTHEP(I).EQ.25) THEN
17955 INEXT = 1
17956 ISTART = I
17957 GOTO 550
17958 ENDIF
17959 500 CONTINUE
17960 550 CONTINUE
17961
17962C debug output
17963 if(IDEB(10).ge.15) then
17964 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17965 & 'hard scattering number: ',NHD/100
17966 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17967 & 'number of entries to rotate: ',IROT
17968 DO I=1,IROT
17969 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17970 & 'entries to rotate: ',I,IROTT(I)
17971 ENDDO
17972 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17973 & 'number of entries to balance: ',IBAL
17974 DO J=1,2
17975 DO I=1,IBAL(J)
17976 WRITE(LO,'(1X,2A,I2,2I5)')
17977 & 'PHO_PRIMKT: entries to balance (side,no,line)',
17978 & J,I,IBALT(I,J)
17979 ENDDO
17980 ENDDO
17981 endif
17982
17983C incoming partons (comment lines), skip direct interacting particles
17984 DO 120 K=1,2
17985 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
17986 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
17987 J = 1
17988 ELSE
17989 J = 2
17990 ENDIF
17991 IBAL(J) = IBAL(J)+1
17992 IBALT(IBAL(J),J) = -ICOM-K
17993 XP2(IBAL(J),J) = POLD(1,J)/ECMP
17994 IV2(IBAL(J),J) = -1
17995 ENDIF
17996 120 CONTINUE
17997
17998C check consistency
17999 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18000 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18001 & 'inconsistent hard scattering remnant for event: ',KEVENT
18002 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18003 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18004 & IMODE,IF,IL,PTCUT
18005 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18006 DO 390 I=1,IROT
18007 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18008 390 CONTINUE
18009 DO 392 J=1,2
18010 DO 395 I=1,IBAL(J)
18011 WRITE(LO,'(1X,A,I2,2I5)')
18012 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18013 395 CONTINUE
18014 392 CONTINUE
18015 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18016 ENDIF
18017
18018C calculate primordial kt
18019
18020C something to do?
18021 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18022
18023C add transverse momentum (overwrite /POEVT1/ entries)
18024 DO 200 J=1,2
18025 IF(IBAL(J).GT.1) THEN
18026C sample from truncated distribution
18027 K = IBAL(J)
18028 DO 180 I=1,K
18029 IV(I) = IV2(I,J)
18030 XP(I) = XP2(I,J)
18031 180 CONTINUE
18032 190 CONTINUE
18033 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18034 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18035C transform incoming partons of hard scattering
18036 DEL = ABS(POLD(1,J))+POLD(2,J)
18037 PT2 = PTS(0,K)**2
18038 DEL2 = DEL*DEL
18039 PNEW(1,J) = PTS(1,K)
18040 PNEW(2,J) = PTS(2,K)
18041 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18042 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18043C spectator partons
18044 ESUM = 0.D0
18045 DO 220 I=1,IBAL(J)-1
18046 K = IBALT(I,J)
18047 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18048 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18049 ESUM = ESUM+PHEP(4,K)
18050 220 CONTINUE
18051C long. momentum transfer
18052 PP(3) = PNEW(3,J) - POLD(1,J)
18053 PP(4) = PNEW(4,J) - POLD(2,J)
18054 DO 230 I=1,IBAL(J)-1
18055 K = IBALT(I,J)
18056 FAC = PHEP(4,K)/ESUM
18057 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18058 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18059 230 CONTINUE
18060
18061C debug output
18062 IF(IDEB(10).GE.15) THEN
18063 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18064 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18065 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18066 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18067 ENDIF
18068
18069 ELSE
18070 PNEW(1,J) = 0.D0
18071 PNEW(2,J) = 0.D0
18072 PNEW(3,J) = POLD(1,J)
18073 PNEW(4,J) = POLD(2,J)
18074 ENDIF
18075 200 CONTINUE
18076
18077C transformation of hard scattering final states (including ISR)
18078
18079C old parton c.m. energy
18080 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18081 EI = SQRT(SI)
18082C new parton c.m. energy
18083 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18084 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18085 EF = SQRT(SF)
18086 FAC = EF/EI
18087C debug output
18088 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18089 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18090
18091C calculate Lorentz transformation
18092 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18093 GAE = (POLD(2,1)+POLD(2,2))/EI
18094 DO 240 I=1,4
18095 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18096 240 CONTINUE
18097 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18098 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18099 PTOT = MAX(DEPS,PTOT)
18100 COD= PP(3)/PTOT
18101 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18102 COF= 1.D0
18103 SIF= 0.D0
18104 IF(PTOT*SID.GT.1.D-5) THEN
18105 COF=PP(1)/(SID*PTOT)
18106 SIF=PP(2)/(SID*PTOT)
18107 ANORF=SQRT(COF*COF+SIF*SIF)
18108 COF=COF/ANORF
18109 SIF=SIF/ANORF
18110 ENDIF
18111
18112C debug output
18113C check consistency initial/final configuration before rotation
18114 IF(IDEB(10).GE.25) THEN
18115 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18116 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18117 DO I=1,4
18118 PP(I) = 0.D0
18119 ENDDO
18120 DO I=1,IROT
18121 K = IROTT(I)
18122 DO J=1,4
18123 PP(J) = PP(J)+PHEP(J,K)
18124 ENDDO
18125 ENDDO
18126 WRITE(LO,'(1X,A,1P,4E11.3)')
18127 & 'PHO_PRIMKT: fin. momentum (1):',PP
18128 ENDIF
18129
18130C apply rotation/boost to scattered particles
18131 DO 400 I=1,IROT
18132 K = IROTT(I)
18133 DO 350 J=1,4
18134 PP(J) = FAC*PHEP(J,K)
18135 350 CONTINUE
18136 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18137 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18138 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18139 & COD,SID,COF,SIF,XX,YY,ZZ)
18140 EE = PHEP(4,K)
18141 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18142 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18143 400 CONTINUE
18144
18145C debug output
18146C check consistency initial/final configuration after rotation
18147 IF(IDEB(10).GE.25) THEN
18148 DO I=1,4
18149 PP(I) = PNEW(I,1)+PNEW(I,2)
18150 ENDDO
18151 WRITE(LO,'(1X,A,1P,4E11.3)')
18152 & 'PHO_PRIMKT: ini. momentum (2):',PP
18153 DO I=1,4
18154 PP(I) = 0.D0
18155 ENDDO
18156 DO I=1,IROT
18157 K = IROTT(I)
18158 DO J=1,4
18159 PP(J) = PP(J)+PHEP(J,K)
18160 ENDDO
18161 ENDDO
18162 WRITE(LO,'(1X,A,1P,4E11.3)')
18163 & 'PHO_PRIMKT: fin. momentum (2):',PP
18164 ENDIF
18165
18166 ENDIF
18167
18168 IF(INEXT.EQ.1) GOTO 100
18169
18170C initialization
18171
18172 ELSE IF(IMODE.EQ.-1) THEN
18173
18174C output of statistics etc.
18175
18176 ELSE IF(IMODE.EQ.-2) THEN
18177
18178C something wrong
18179
18180 ELSE
18181 WRITE(LO,'(/1X,A,I4)')
18182 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18183 CALL PHO_ABORT
18184 ENDIF
18185
18186 END
18187
18188*$ CREATE PHO_PARTPT.FOR
18189*COPY PHO_PARTPT
18190CDECK ID>, PHO_PARTPT
18191 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18192C********************************************************************
18193C
18194C assign to soft partons
18195C
18196C input: IMODE -2 output of statistics
18197C -1 initialization
18198C 0 sampling of pt for soft partons belonging to
18199C soft Pomerons
18200C 1 sampling of pt for soft partons belonging to
18201C hard Pomerons
18202C IF first entry in /POEVT1/ to check
18203C IL last entry in /POEVT1/ to check
18204C PTCUT current value of PTCUT to distinguish
18205C between soft and hard
18206C
18207C output: IREJ 0 success
18208C 1 failure
18209C
18210C (soft pt is sampled by call to PHO_SOFTPT)
18211C
18212C********************************************************************
18213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18214 SAVE
18215
18216 PARAMETER ( DEPS = 1.D-15 )
18217
18218 INTEGER IMODE,IF,IL,IREJ
18219 DOUBLE PRECISION PTCUT
18220
18221C input/output channels
18222 INTEGER LI,LO
18223 COMMON /POINOU/ LI,LO
18224C event debugging information
18225 INTEGER NMAXD
18226 PARAMETER (NMAXD=100)
18227 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18228 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18229 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18230 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18231C model switches and parameters
18232 CHARACTER*8 MDLNA
18233 INTEGER ISWMDL,IPAMDL
18234 DOUBLE PRECISION PARMDL
18235 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18236C some constants
18237 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18238 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18239 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18240C data of c.m. system of Pomeron / Reggeon exchange
18241 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18242 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18243 & SIDP,CODP,SIFP,COFP
18244 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18245 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18246 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18247C standard particle data interface
18248 INTEGER NMXHEP
18249 PARAMETER (NMXHEP=4000)
18250 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18251 DOUBLE PRECISION PHEP,VHEP
18252 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18253 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18254 & VHEP(4,NMXHEP)
18255C extension to standard particle data interface (PHOJET specific)
18256 INTEGER IMPART,IPHIST,ICOLOR
18257 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18258
18259 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18260 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18261
18262 INTEGER MODIFY,IV,IVB
18263 DIMENSION MODIFY(50),IV(50),IVB(2)
18264
18265C debug output
18266 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18267 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18268 & IMODE,IF,IL,PTCUT
18269
18270 IF(IMODE.LT.0) GOTO 1000
18271
18272 IREJ = 0
18273 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18274
18275C count entries to modify
18276 IENTRY = 0
18277 PTCUT2 = PTCUT**2
18278 EMIN = 1.D20
18279 IPEAK = 1
18280 ISTART = IF
18281
18282C soft Pomerons
18283
18284 IF(IMODE.EQ.0) THEN
18285 DO 300 I=ISTART,IL
18286 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18287 IENTRY = IENTRY+1
18288 MODIFY(IENTRY) = I
18289 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18290 IV(IENTRY) = 0
18291 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18292 IF(PHEP(4,I).LT.EMIN) THEN
18293 EMIN = PHEP(4,I)
18294 IPEAK = IENTRY
18295 ENDIF
18296 ENDIF
18297 300 CONTINUE
18298
18299C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18300
18301 ELSE IF(IMODE.EQ.1) THEN
18302
18303 DO 350 I=ISTART,IL
18304 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18305 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18306 IENTRY = IENTRY+1
18307 MODIFY(IENTRY) = I
18308 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18309 IF(ISWMDL(24).EQ.0) THEN
18310 IV(IENTRY) = 0
18311 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18312 ELSE IF(ISWMDL(24).EQ.1) THEN
18313 IV(IENTRY) = -1
18314 ELSE
18315 IV(IENTRY) = 1
18316 ENDIF
18317 IF(PHEP(4,I).LT.EMIN) THEN
18318 EMIN = PHEP(4,I)
18319 IPEAK = IENTRY
18320 ENDIF
18321 ENDIF
18322 ENDIF
18323 350 CONTINUE
18324
18325C something wrong
18326
18327 ELSE
18328 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18329 CALL PHO_ABORT
18330 ENDIF
18331
18332C debug output
18333 IF(IDEB(6).GE.5) THEN
18334 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18335 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18336 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18337 ENDIF
18338
18339C nothing to do
18340 IF(IENTRY.LE.1) RETURN
18341
18342C sample pt of soft partons
18343
18344 IF(ISWMDL(5).LE.1) THEN
18345 ITER = 0
18346 IPEAK = DT_RNDM(DUM)*IENTRY+1
18347 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18348 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18349 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18350 400 CONTINUE
18351C energy limited sampling
18352 PSUMX = 0.D0
18353 PSUMY = 0.D0
18354 ITER = ITER+1
18355 IF(ITER.GE.1000) THEN
18356 IF(IDEB(6).GE.3) THEN
18357 WRITE(LO,'(1X,A,3I5)')
18358 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18359 & IMODE,IENTRY,ITER
18360 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18361 & IPEAK
18362 DO 405 I=1,IENTRY
18363 II = MODIFY(I)
18364 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18365 & I,II,IV(I),XP(I),PHEP(4,II)
18366 405 CONTINUE
18367 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18368 ENDIF
18369 IREJ = 1
18370 RETURN
18371 ENDIF
18372 DO 410 I=2,IENTRY
18373 II = MODIFY(I)
18374 PTMX = MIN(PHEP(4,II),PTCUT)
18375 XPB(1) = XP(I)
18376 IVB(1) = IV(I)
18377 IF(ISWMDL(5).EQ.0) THEN
18378 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18379 ELSE
18380 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18381 ENDIF
18382 PTS(0,I) = PB(0,1)
18383 PTS(1,I) = PB(1,1)
18384 PTS(2,I) = PB(2,1)
18385 PSUMX = PSUMX+PB(1,1)
18386 PSUMY = PSUMY+PB(2,1)
18387 410 CONTINUE
18388 PTREM = SQRT(PSUMX**2+PSUMY**2)
18389 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18390 PTS(1,1) = -PSUMX
18391 PTS(2,1) = -PSUMY
18392 ELSE IF((ISWMDL(5).EQ.2)
18393 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18394C unlimited sampling
18395 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18396 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18397 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18398 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18399 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18400 ELSE IF(ISWMDL(5).EQ.3) THEN
18401C each string has balanced pt
18402 DO 500 K=1,IENTRY
18403 IF(IV(K).LE.-90) GOTO 499
18404 I1 = MODIFY(K)
18405 IC1 = -ICOLOR(1,I1)
18406 DO 510 L=K+1,IENTRY
18407 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18408 510 CONTINUE
18409 WRITE(LO,'(//1X,A,I5)')
18410 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18411 CALL PHO_ABORT
18412 511 CONTINUE
18413 I2 = MODIFY(L)
18414 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18415 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18416 AM = SQRT(AMSQR)
18417 PTMX = AM/2.D0
18418 IVB(1) = MAX(IV(K),IV(L))
18419 XPB(1) = XP(K)
18420 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18421 PTS(1,K) = PB(1,1)
18422 PTS(2,K) = PB(2,1)
18423 PTS(1,L) = -PB(1,1)
18424 PTS(2,L) = -PB(2,1)
18425 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18426 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18427 PC(1) = PB(1,1)
18428 PC(2) = PB(2,1)
18429 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18430 PC(3) = SIGN(PLONG,PHEP(3,I1))
18431 PC(4) = PTMX
18432 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18433 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18434 PC(1) = -PC(1)
18435 PC(2) = -PC(2)
18436 PC(3) = -PC(3)
18437 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18438 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18439 IV(K) = IV(K)-100
18440 IV(L) = IV(L)-100
18441 499 CONTINUE
18442 500 CONTINUE
18443 ELSE
18444 WRITE(LO,'(/1X,A,I4)')
18445 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18446 CALL PHO_ABORT
18447 ENDIF
18448
18449C change partons in /POEVT1/
18450 DO 900 II=1,IENTRY
18451 IF(IV(II).GT.-90) THEN
18452 I = MODIFY(II)
18453 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18454 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18455 AMSQR = PHEP(4,I)**2
18456 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18457 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18458 ENDIF
18459 900 CONTINUE
18460
18461C debug output
18462 IF(IDEB(6).GE.15) THEN
18463 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18464 & 'I II IV XP EP PTS PTX PTY',IPEAK
18465 DO 505 I=1,IENTRY
18466 II = MODIFY(I)
18467 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18468 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18469 505 CONTINUE
18470 CALL PHO_PREVNT(0)
18471 ENDIF
18472 RETURN
18473
18474C initialization / output of statistics
18475 1000 CONTINUE
18476 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18477
18478 END
18479
18480*$ CREATE PHO_SOFTPT.FOR
18481*COPY PHO_SOFTPT
18482CDECK ID>, PHO_SOFTPT
18483 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18484C***********************************************************************
18485C
18486C select pt of soft string ends
18487C
18488C input: ISOFT number of soft partons
18489C -1 initialization
18490C >=0 sampling of p_t
18491C -2 output of statistics
18492C PTCUT cutoff for soft strings
18493C PTMAX maximal allowed PT
18494C XV field of x values
18495C IV 0 sea quark
18496C 1 valence quark
18497C
18498C output: /POINT3/ containing parameters AAS,BETAS
18499C PTSOF filed with soft pt values
18500C
18501C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18502C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18503C ISWMDL(3/4) = 2 photon wave function
18504C ISWMDL(3/4) = 10 no soft P_t assignment
18505C
18506C***********************************************************************
18507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18508 SAVE
18509
18510 PARAMETER ( DEPS = 1.D-15)
18511
18512 DIMENSION PTSOF(0:2,*),XV(*)
18513 DIMENSION IV(*)
18514
18515C input/output channels
18516 INTEGER LI,LO
18517 COMMON /POINOU/ LI,LO
18518C event debugging information
18519 INTEGER NMAXD
18520 PARAMETER (NMAXD=100)
18521 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18522 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18523 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18524 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18525C model switches and parameters
18526 CHARACTER*8 MDLNA
18527 INTEGER ISWMDL,IPAMDL
18528 DOUBLE PRECISION PARMDL
18529 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18530C data of c.m. system of Pomeron / Reggeon exchange
18531 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18532 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18533 & SIDP,CODP,SIFP,COFP
18534 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18535 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18536 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18537C data on most recent hard scattering
18538 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18539 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18540 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18541 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18542 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18543 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18544 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18545 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18546 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18547C data needed for soft-pt calculation
18548 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18549 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18550
18551 DIMENSION BETAB(100)
18552
18553C selection of pt
18554 IF(ISOFT.GE.0) THEN
18555 CALLS = CALLS + 1.D0
18556C sample according to model ISWMDL(3-6)
18557 IF(ISOFT.GT.1) THEN
18558 210 CONTINUE
18559 PTXS = 0.D0
18560 PTYS = 0.D0
18561 DO 300 I=2,ISOFT
18562 IMODE = ISWMDL(3)
18563C valence partons
18564 IF(IV(I).EQ.1) THEN
18565 BETA = BETAS(1)
18566C photon/pomeron valence part
18567 IF(IPAMDL(5).EQ.1) THEN
18568 IF(XV(I).GE.0.D0) THEN
18569 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18570 IMODE = ISWMDL(4)
18571 BETA = BETAS(3)
18572 ENDIF
18573 ELSE
18574 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18575 IMODE = ISWMDL(4)
18576 BETA = BETAS(3)
18577 ENDIF
18578 ENDIF
18579 ELSE IF(IPAMDL(5).EQ.2) THEN
18580 BETA = PARMDL(20)
18581 ELSE IF(IPAMDL(5).EQ.3) THEN
18582 BETA = BETAS(3)
18583 ENDIF
18584C sea partons
18585 ELSE IF(IV(I).EQ.0) THEN
18586 BETA = BETAS(3)
18587C hard scattering remnant
18588 ELSE
18589 IF(IPAMDL(6).EQ.0) THEN
18590 BETA = BETAS(1)
18591 ELSE IF(IPAMDL(6).EQ.1) THEN
18592 BETA = BETAS(3)
18593 ELSE
18594 BETA = PARMDL(20)
18595 ENDIF
18596 ENDIF
18597 BETA = MAX(BETA,0.01D0)
18598 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18599 PTS = MIN(PTMAX,PTS)
18600 CALL PHO_SFECFE(SIG,COG)
18601 PTSOF(0,I) = PTS
18602 PTSOF(1,I) = COG*PTS
18603 PTSOF(2,I) = SIG*PTS
18604 PTXS = PTXS+PTSOF(1,I)
18605 PTYS = PTYS+PTSOF(2,I)
18606 BETAB(I) = BETA
18607 300 CONTINUE
18608C balancing of momenta
18609 PTS = SQRT(PTXS**2+PTYS**2)
18610 IF(PTS.GE.PTMAX) GOTO 210
18611 PTSOF(0,1) = PTS
18612 PTSOF(1,1) = -PTXS
18613 PTSOF(2,1) = -PTYS
18614 BETAB(1) = 0.D0
18615C
18616*400 CONTINUE
18617C
18618C single parton only
18619 ELSE
18620 IMODE = ISWMDL(3)
18621C valence partons
18622 IF(IV(1).EQ.1) THEN
18623 BETA = BETAS(1)
18624C photon/Pomeron valence part
18625 IF(IPAMDL(5).EQ.1) THEN
18626 IF(XV(1).GE.0.D0) THEN
18627 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18628 IMODE = ISWMDL(4)
18629 BETA = BETAS(3)
18630 ENDIF
18631 ELSE
18632 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18633 IMODE = ISWMDL(4)
18634 BETA = BETAS(3)
18635 ENDIF
18636 ENDIF
18637 ELSE IF(IPAMDL(5).EQ.2) THEN
18638 BETA = PARMDL(20)
18639 ELSE IF(IPAMDL(5).EQ.3) THEN
18640 BETA = BETAS(3)
18641 ENDIF
18642C sea partons
18643 ELSE IF(IV(1).EQ.0) THEN
18644 BETA = BETAS(3)
18645C hard scattering remnant
18646 ELSE
18647 IF(IPAMDL(6).EQ.1) THEN
18648 BETA = BETAS(3)
18649 ELSE
18650 BETA = PARMDL(20)
18651 ENDIF
18652 ENDIF
18653 BETA = MAX(BETA,0.01D0)
18654 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18655 PTS = MIN(PTMAX,PTS)
18656 CALL PHO_SFECFE(SIG,COG)
18657 PTSOF(0,1) = PTS
18658 PTSOF(1,1) = COG*PTS
18659 PTSOF(2,1) = SIG*PTS
18660 BETAB(1) = BETA
18661 ENDIF
18662C debug output
18663 IF(IDEB(29).GE.10) THEN
18664 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18665 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18666 DO 105 I=1,ISOFT
18667 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18668 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18669 105 CONTINUE
18670 ENDIF
18671
18672C initialization of statistics and parameters
18673
18674 ELSE IF(ISOFT.EQ.-1) THEN
18675 PTSMIN = 0.D0
18676 PTSMAX = PTCUT
18677 IMODE = -100+ISWMDL(3)
18678 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18679
18680C output of statistics
18681
18682 ELSE IF(ISOFT.EQ.-2) THEN
18683 ELSE
18684 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18685 & 'unsupported ISOFT ',ISOFT
18686 STOP
18687 ENDIF
18688 END
18689
18690*$ CREATE PHO_SELPT.FOR
18691*COPY PHO_SELPT
18692CDECK ID>, PHO_SELPT
18693 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18694C***********************************************************************
18695C
18696C select pt from different distributions
18697C
18698C input: EE energy (for initialization only)
18699C otherwise x value of corresponding parton
18700C PTLOW lower pt limit
18701C PTHIGH upper pt limit
18702C (PTHIGH > 20 will cause DEXP underflows)
18703C
18704C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18705C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18706C IMODE = 2 dNs/dP_t according photon wave function
18707C IMODE = 10 no sampling
18708C
18709C IMODE = -100+IMODE initialization according to
18710C given limitations
18711C
18712C output: PTS sampled pt value
18713C initialization:
18714C BETA soft pt slope in central region
18715C
18716C***********************************************************************
18717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18718 SAVE
18719
18720 PARAMETER ( PI2 = 6.28318530718D0,
18721 & AMIN = 1.D-2,
18722 & EPS = 1.D-7,
18723 & DEPS = 1.D-30)
18724
18725C input/output channels
18726 INTEGER LI,LO
18727 COMMON /POINOU/ LI,LO
18728C event debugging information
18729 INTEGER NMAXD
18730 PARAMETER (NMAXD=100)
18731 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18732 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18733 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18734 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18735C model switches and parameters
18736 CHARACTER*8 MDLNA
18737 INTEGER ISWMDL,IPAMDL
18738 DOUBLE PRECISION PARMDL
18739 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18740C data of c.m. system of Pomeron / Reggeon exchange
18741 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18742 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18743 & SIDP,CODP,SIFP,COFP
18744 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18745 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18746 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18747C average number of cut soft and hard ladders (obsolete)
18748 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18749 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18750C data needed for soft-pt calculation
18751 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18752 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18753
18754 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18755 EXTERNAL PHO_CONN0,PHO_CONN1
18756
18757C initialization
18758
18759 IF(IMODE.LT.0) GOTO 100
18760
18761 PX = PTHIGH
18762 PTS = 0.D0
18763
18764C initial checks
18765
18766 IF(PX.LT.AMIN) RETURN
18767
18768 IF((PX-PTLOW).LT.0.01) THEN
18769 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18770 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18771 RETURN
18772 ENDIF
18773
18774C sampling of pt values according to IMODE
18775
18776 IF(IMODE.EQ.0) THEN
18777
18778 FAC1 = EXP(-BETA*PX**2)
18779 FAC2 = (1.D0-FAC1)
18780 25 CONTINUE
18781 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18782 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18783 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18784
18785 ELSE IF(IMODE.EQ.1) THEN
18786
18787 XIMIN = EXP(-BETA*PTHIGH)
18788 XIDEL = 1.D0-XIMIN
18789 50 CONTINUE
18790 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18791 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18792 IF(PTS.LT.XMT) GOTO 50
18793 PTS = SQRT(PTS**2-XMT2)
18794 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18795
18796 ELSE IF(IMODE.EQ.2) THEN
18797
18798 IF(EE.GE.0.D0) THEN
18799 P2 = PVIRTP(1)
18800 ELSE
18801 P2 = PVIRTP(2)
18802 ENDIF
18803 XV = ABS(EE)
18804 AA = (1.D0-XV)*XV*P2+PARMDL(25)
18805 75 CONTINUE
18806 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18807 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18808
18809C something wrong
18810
18811 ELSE IF(IMODE.NE.10) THEN
18812 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18813 CALL PHO_ABORT
18814 ENDIF
18815
18816C debug output
18817 IF(IDEB(5).GE.20) THEN
18818 WRITE(LO,'(1X,A,I3,4E10.3)')
18819 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18820 & IMODE,BETA,PTLOW,PTHIGH,PTS
18821 ENDIF
18822 RETURN
18823
18824C initialization
18825 100 CONTINUE
18826 PTSMIN = PTLOW
18827 PTSMAX = PTHIGH
18828 PTCON = PTHIGH
18829C calculation of parameters
18830 INIT = IMODE+100
18831 AAS = 0.D0
18832
18833C initialization for model 0 (gaussian pt distribution)
18834
18835 IF(INIT.EQ.0) THEN
18836 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18837 BETUP = BETAS(1)
18838 BETLO = -2.D0
18839 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18840 IF(XTOL.LT.0.D0) THEN
18841 XTOL = 1.D-4
18842 METHOD = 1
18843 MAXF = 500
18844 BETA = 0.D0
18845 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18846* IF(BETA.LT.-1.D+10) THEN
18847* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18848* & '(model 0: Ecm,PTcut)',EE,PTCON
18849* WRITE(LO,'(1X,A,1P,3E10.3)')
18850* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18851* CALL PHO_PREVNT(-1)
18852* BETA = 0.01
18853* ELSE
18854 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18855* ENDIF
18856 ELSE
18857 AAS = 0.D0
18858 BETA = BETAS(1)
18859 ENDIF
18860
18861C initialization for model 1 (exponential pt distribution)
18862
18863 ELSE IF(INIT.EQ.1) THEN
18864 XMT = PARMDL(43)
18865 XMT2 = XMT*XMT
18866 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18867 BETUP = BETAS(1)
18868 BETLO = -3.D0
18869 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18870 IF(XTOL.LT.0.D0) THEN
18871 XTOL = 1.D-4
18872 METHOD = 1
18873 MAXF = 500
18874 BETA = 0.D0
18875 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18876* IF(BETA.LT.-1.D+10) THEN
18877* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18878* & '(model 1: Ecm,PTcut)',EE,PTCON
18879* WRITE(LO,'(1X,A,1P,3E10.3)')
18880* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18881* CALL PHO_PREVNT(-1)
18882* BETA = 0.01
18883* ELSE
18884 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18885* ENDIF
18886 ELSE
18887 AAS = 0.D0
18888 BETA = BETAS(1)
18889 ENDIF
18890 ELSE IF(INIT.EQ.10) THEN
18891 IF(IDEB(5).GT.10)
18892 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18893 RETURN
18894 ELSE
18895 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18896 & INIT
18897 CALL PHO_ABORT
18898 ENDIF
18899 BETA = MIN(BETA,BETAS(1))
18900
18901C hard cross section is too big: neg. beta parameter
18902 IF(BETA.LE.0.D0) THEN
18903 WRITE(LO,'(1X,A,1P,2E12.3)')
18904 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18905 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18906 & SIGS,DSIGHP,SIGH,PTCON
18907 CALL PHO_PREVNT(-1)
18908 ENDIF
18909
18910C output of initialization parameters
18911 IF(IDEB(5).GE.10) THEN
18912 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18913 & INIT
18914 WRITE(LO,'(5X,A,1P,2E13.3)')
18915 & 'BETA,AAS ',BETA,AAS
18916 WRITE(LO,'(5X,A,1P,3E13.3)')
18917 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18918 WRITE(LO,'(5X,A,1P,3E13.3)')
18919 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18920 ENDIF
18921
18922 END
18923
18924*$ CREATE PHO_CONN0.FOR
18925*COPY PHO_CONN0
18926CDECK ID>, PHO_CONN0
18927 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18928C***********************************************************************
18929C
18930C auxiliary function to determine parameters of soft
18931C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18932C
18933C internal factors: FS number of soft partons in soft Pomeron
18934C FH number of soft partons in hard Pomeron
18935C
18936C***********************************************************************
18937 IMPLICIT NONE
18938 SAVE
18939
18940C input/output channels
18941 INTEGER LI,LO
18942 COMMON /POINOU/ LI,LO
18943C average number of cut soft and hard ladders (obsolete)
18944 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18945 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18946C data needed for soft-pt calculation
18947 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18948 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18949
18950 DOUBLE PRECISION BETA,XX,FF
18951
18952 XX = BETA*PTCON**2
18953 IF(ABS(XX).LT.1.D-3) THEN
18954 FF = FS*SIGS+FH*SIGH
18955 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18956 ELSE
18957 FF = FS*SIGS+FH*SIGH
18958 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18959 ENDIF
18960 PHO_CONN0 = FF
18961
18962* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18963* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18964
18965 END
18966
18967*$ CREATE PHO_CONN1.FOR
18968*COPY PHO_CONN1
18969CDECK ID>, PHO_CONN1
18970 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18971C***********************************************************************
18972C
18973C auxiliary function to determine parameters of soft
18974C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18975C
18976C internal factors: FS number of soft partons in soft Pomeron
18977C FH number of soft partons in hard Pomeron
18978C
18979C***********************************************************************
18980 IMPLICIT NONE
18981 SAVE
18982
18983C input/output channels
18984 INTEGER LI,LO
18985 COMMON /POINOU/ LI,LO
18986C average number of cut soft and hard ladders (obsolete)
18987 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18988 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18989C data needed for soft-pt calculation
18990 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18991 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18992
18993 DOUBLE PRECISION BETA,XX,FF
18994
18995 XX = BETA*PTCON
18996 IF(ABS(XX).LT.1.D-3) THEN
18997 FF = FS*SIGS+FH*SIGH
18998 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
18999 ELSE
19000 FF = FS*SIGS+FH*SIGH
19001 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19002 ENDIF
19003 PHO_CONN1 = FF
19004
19005* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19006* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19007
19008 END
19009
19010*$ CREATE PHO_MSHELL.FOR
19011*COPY PHO_MSHELL
19012CDECK ID>, PHO_MSHELL
19013 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19014C********************************************************************
19015C
19016C rescaling of momenta of two partons to put both
19017C on mass shell
19018C
19019C input: PA1,PA2 input momentum vectors
19020C XM1,2 desired masses of particles afterwards
19021C P1,P2 changed momentum vectors
19022C
19023C********************************************************************
19024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19025 SAVE
19026
19027 PARAMETER ( DEPS = 1.D-20 )
19028
19029 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19030
19031C input/output channels
19032 INTEGER LI,LO
19033 COMMON /POINOU/ LI,LO
19034C event debugging information
19035 INTEGER NMAXD
19036 PARAMETER (NMAXD=100)
19037 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19038 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19039 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19040 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19041C internal rejection counters
19042 INTEGER NMXJ
19043 PARAMETER (NMXJ=60)
19044 CHARACTER*10 REJTIT
19045 INTEGER IFAIL
19046 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19047
19048 IREJ = 0
19049 IDEV = 0
19050C debug output
19051 IF(IDEB(40).GE.10) THEN
19052 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19053 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19054 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19055 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19056 ENDIF
19057
19058C Lorentz transformation into system CMS
19059 PX = PA1(1)+PA2(1)
19060 PY = PA1(2)+PA2(2)
19061 PZ = PA1(3)+PA2(3)
19062 EE = PA1(4)+PA2(4)
19063 XMS = EE**2-PX**2-PY**2-PZ**2
19064 IF(XMS.LT.(XM1+XM2)**2) THEN
19065 IREJ = 1
19066 IFAIL(37) = IFAIL(37)+1
19067
19068 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19069
19070 IF(IDEB(40).GE.3) THEN
19071 WRITE(LO,'(/1X,A,I12)')
19072 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19073 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19074 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19075 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19076 IDEV = 5
19077 IF(IDEB(40).GE.3) GOTO 55
19078 ENDIF
19079 RETURN
19080 ENDIF
19081 XMS = SQRT(XMS)
19082 BGX = PX/XMS
19083 BGY = PY/XMS
19084 BGZ = PZ/XMS
19085 GAM = EE/XMS
19086 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19087 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19088C rotation angles
19089 PTOT1 = MAX(DEPS,PTOT1)
19090 COD = P1(3)/PTOT1
19091 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19092 COF = 1.D0
19093 SIF = 0.D0
19094 IF(PTOT1*SID.GT.1.D-5) THEN
19095 COF = P1(1)/(SID*PTOT1)
19096 SIF = P1(2)/(SID*PTOT1)
19097 ANORF = SQRT(COF*COF+SIF*SIF)
19098 COF = COF/ANORF
19099 SIF = SIF/ANORF
19100 ENDIF
19101
19102C new CM momentum and energies (for masses XM1,XM2)
19103 XM12 = XM1**2
19104 XM22 = XM2**2
19105 SS = XMS**2
19106 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19107 EE1 = SQRT(XM12+PCMP**2)
19108 EE2 = XMS-EE1
19109C back rotation
19110 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19111 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19112 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19113 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19114 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19115
19116C check consistency
19117 DEL = XMS*0.0001
19118 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19119 IDEV = 1
19120 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19121 IDEV = 2
19122 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19123 IDEV = 3
19124 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19125 IDEV = 4
19126 ENDIF
19127 55 CONTINUE
19128C debug output
19129 IF(IDEV.NE.0) THEN
19130 WRITE(LO,'(1X,A,I3)')
19131 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19132 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19133 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19134 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19135 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19136 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19137 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19138 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19139 ELSE IF(IDEB(40).GE.10) THEN
19140 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19141 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19142 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19143 ENDIF
19144 END
19145
19146*$ CREATE PHO_GLU2QU.FOR
19147*COPY PHO_GLU2QU
19148CDECK ID>, PHO_GLU2QU
19149 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19150C********************************************************************
19151C
19152C split gluon with index I in POEVT1
19153C (massless gluon assumed)
19154C
19155C input: /POEVT1/
19156C IG gluon index
19157C IQ1 first quark index
19158C IQ2 second quark index
19159C
19160C output: new quarks in /POEVT1/
19161C IREJ 1 splitting impossible
19162C 0 splitting successful
19163C
19164C********************************************************************
19165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19166 SAVE
19167
19168 PARAMETER ( DEPS = 1.D-15,
19169 & EPS = 1.D-5 )
19170
19171C input/output channels
19172 INTEGER LI,LO
19173 COMMON /POINOU/ LI,LO
19174C event debugging information
19175 INTEGER NMAXD
19176 PARAMETER (NMAXD=100)
19177 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19178 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19179 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19180 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19181C model switches and parameters
19182 CHARACTER*8 MDLNA
19183 INTEGER ISWMDL,IPAMDL
19184 DOUBLE PRECISION PARMDL
19185 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19186C standard particle data interface
19187 INTEGER NMXHEP
19188 PARAMETER (NMXHEP=4000)
19189 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19190 DOUBLE PRECISION PHEP,VHEP
19191 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19192 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19193 & VHEP(4,NMXHEP)
19194C extension to standard particle data interface (PHOJET specific)
19195 INTEGER IMPART,IPHIST,ICOLOR
19196 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19197C internal rejection counters
19198 INTEGER NMXJ
19199 PARAMETER (NMXJ=60)
19200 CHARACTER*10 REJTIT
19201 INTEGER IFAIL
19202 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19203
19204 DIMENSION P1(4),P2(4)
19205 DATA CUTM /0.02D0/
19206
19207 IREJ = 0
19208
19209C calculate string masses max possible
19210 IF(ISWMDL(9).EQ.1) THEN
19211 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19212 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19213 IF(CMASS1.LT.CUTM) THEN
19214 IF(IDEB(73).GE.5) THEN
19215 WRITE(LO,'(1X,A,3I4,4E10.3)')
19216 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19217 ENDIF
19218 IFAIL(33) = IFAIL(33) + 1
19219 IREJ = 1
19220 RETURN
19221 ENDIF
19222 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19223 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19224 IF(CMASS2.LT.CUTM) THEN
19225 IF(IDEB(73).GE.5) THEN
19226 WRITE(LO,'(1X,A,3I4,4E10.3)')
19227 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19228 ENDIF
19229 IFAIL(33) = IFAIL(33) + 1
19230 IREJ = 1
19231 RETURN
19232 ENDIF
19233C
19234C calculate minimal z
19235 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19236 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19237 ZMIN = MIN(ZMIN1,ZMIN2)
19238 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19239 IF(IDEB(73).GE.5) THEN
19240 WRITE(LO,'(1X,A,3I3,4E10.3)')
19241 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19242 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19243 ENDIF
19244 IFAIL(33) = IFAIL(33) + 1
19245 IREJ = 1
19246 RETURN
19247 ENDIF
19248 ELSE
19249 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19250 ENDIF
19251C
19252 ZFRAC = PHO_GLUSPL(ZMIN)
19253 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19254 ZFRAC = 1.D0-ZFRAC
19255 ENDIF
19256 DO 200 I=1,4
19257 P1(I) = PHEP(I,IG)*ZFRAC
19258 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19259 200 CONTINUE
19260C quark flavours
19261 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19262 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19263 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19264 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19265 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19266 K = SIGN(ABS(K),IDHEP(IQ1))
19267 ELSE
19268 K = -SIGN(ABS(K),IDHEP(IQ1))
19269 ENDIF
19270C colors
19271 IF(K.GT.0) THEN
19272 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19273 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19274 ELSE
19275 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19276 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19277 ENDIF
19278C register new partons
19279 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19280 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19281 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19282 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19283C debug output
19284 IF(IDEB(73).GE.20) THEN
19285 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19286 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19287 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19288 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19289 & K,-K,IC1,IC2
19290 ENDIF
19291 END
19292
19293*$ CREATE PHO_GLUSPL.FOR
19294*COPY PHO_GLUSPL
19295CDECK ID>, PHO_GLUSPL
19296 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19297C*********************************************************************
19298C
19299C calculate quark - antiquark light cone momentum fractions
19300C according to Altarelli-Parisi g->q aq splitting function
19301C (symmetric z interval assumed)
19302C
19303C input: ZMIN minimal Z value allowed,
19304C 1-ZMIN maximal Z value allowed
19305C
19306C********************************************************************
19307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19308 SAVE
19309
19310 PARAMETER ( ALEXP= 0.3333333333D0,
19311 & DEPS = 1.D-10 )
19312
19313C input/output channels
19314 INTEGER LI,LO
19315 COMMON /POINOU/ LI,LO
19316C event debugging information
19317 INTEGER NMAXD
19318 PARAMETER (NMAXD=100)
19319 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19320 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19321 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19322 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19323
19324 IF(ZMIN.GE.0.5D0) THEN
19325 IF(IDEB(69).GT.2) THEN
19326 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19327 ENDIF
19328 ZZ=0.D0
19329 GOTO 1000
19330 ELSE IF(ZMIN.LE.0.D0) THEN
19331 IF(IDEB(69).GT.2) THEN
19332 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19333 ENDIF
19334 ZMINL = DEPS
19335 ELSE
19336 ZMINL = ZMIN
19337 ENDIF
19338
19339 ZMAX = 1.D0-ZMINL
19340 XI = DT_RNDM(ZMAX)
19341 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19342 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19343
19344 1000 CONTINUE
19345 IF(IDEB(69).GE.10) THEN
19346 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19347 ENDIF
19348 PHO_GLUSPL = ZZ
19349 END
19350
19351*$ CREATE PHO_STDPAR.FOR
19352*COPY PHO_STDPAR
19353CDECK ID>, PHO_STDPAR
19354 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19355C***********************************************************************
19356C
19357C select the initial parton x-fractions and flavors and
19358C the final parton momenta and flavours
19359C for standard Pomeron/Reggeon cuts
19360C
19361C input: IJM1 index of mother particle 1 in /POEVT1/
19362C IJM2 index of mother particle 2 in /POEVT1/
19363C IGEN production process of mother particles
19364C MSPOM soft cut Pomerons
19365C MHPOM hard or semihard cut Pomerons
19366C MSREG soft cut Reggeons
19367C MHDIR direct hard processes
19368C
19369C IJM1 -1 initialization of statistics
19370C -2 output of statistics
19371C
19372C output: partons are directly written to /POEVT1/,/POEVT2/
19373C
19374C structure of /POSOFT/
19375C XS1(I),XS2(I): x-values of initial partons
19376C IJSI1(I),IJSI2(I): flavor of initial parton
19377C 0 gluon
19378C 1,2,3,4 quarks
19379C negative antiquarks
19380C IJSF1(I),IJSF2(I): flavor of final state partons
19381C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19382C J=1 PX
19383C =2 PY
19384C =3 PZ
19385C =4 ENERGY
19386C
19387C***********************************************************************
19388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19389 SAVE
19390
19391 PARAMETER (RHOMAS = 0.766D0,
19392 & DEPS = 1.D-10,
19393 & TINY = 1.D-10)
19394
19395C input/output channels
19396 INTEGER LI,LO
19397 COMMON /POINOU/ LI,LO
19398C event debugging information
19399 INTEGER NMAXD
19400 PARAMETER (NMAXD=100)
19401 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19402 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19403 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19404 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19405C model switches and parameters
19406 CHARACTER*8 MDLNA
19407 INTEGER ISWMDL,IPAMDL
19408 DOUBLE PRECISION PARMDL
19409 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19410C some constants
19411 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19412 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19413 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19414C general process information
19415 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19416 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19417C global event kinematics and particle IDs
19418 INTEGER IFPAP,IFPAB
19419 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19420 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19421C data of c.m. system of Pomeron / Reggeon exchange
19422 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19423 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19424 & SIDP,CODP,SIFP,COFP
19425 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19426 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19427 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19428C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19429 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19430 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19431 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19432 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19433C obsolete cut-off information
19434 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19435 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19436C currently activated parton density parametrizations
19437 CHARACTER*8 PDFNAM
19438 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19439 DOUBLE PRECISION PDFLAM,PDFQ2M
19440 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19441 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19442C hard scattering parameters used for most recent hard interaction
19443 INTEGER NFbeta,NF
19444 DOUBLE PRECISION ALQCD2,BQCD
19445 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19446C particles created by initial state evolution
19447 INTEGER MXISR1,MXISR2
19448 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19449 INTEGER IFLISR,IPOISR,IMXISR
19450 DOUBLE PRECISION PHISR
19451 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19452 & IPOISR(2,2,MXISR2),IMXISR(2)
19453C light-cone x fractions and c.m. momenta of soft cut string ends
19454 INTEGER MAXSOF
19455 PARAMETER ( MAXSOF = 50 )
19456 INTEGER IJSI2,IJSI1
19457 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19458 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19459 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19460 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19461C table of particle indices for recursive PHOJET calls
19462 INTEGER MAXIPX
19463 PARAMETER ( MAXIPX = 100 )
19464 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19465 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19466 & IPOIX1,IPOIX2,IPOIX3
19467C hard scattering data
19468 INTEGER MSCAHD
19469 PARAMETER ( MSCAHD = 50 )
19470 INTEGER LSCAHD,LSC1HD,LSIDX,
19471 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19472 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19473 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19474 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19475 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19476 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19477 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19478 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19479 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19480C standard particle data interface
19481 INTEGER NMXHEP
19482 PARAMETER (NMXHEP=4000)
19483 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19484 DOUBLE PRECISION PHEP,VHEP
19485 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19486 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19487 & VHEP(4,NMXHEP)
19488C extension to standard particle data interface (PHOJET specific)
19489 INTEGER IMPART,IPHIST,ICOLOR
19490 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19491C internal rejection counters
19492 INTEGER NMXJ
19493 PARAMETER (NMXJ=60)
19494 CHARACTER*10 REJTIT
19495 INTEGER IFAIL
19496 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19497C internal cross check information on hard scattering limits
19498 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19499 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19500C hard cross sections and MC selection weights
19501 INTEGER Max_pro_2
19502 PARAMETER ( Max_pro_2 = 16 )
19503 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19504 & MH_acc_1,MH_acc_2
19505 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19506 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19507 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19508 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19509 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19510 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19511
19512 double precision pho_alphas
19513
19514 DIMENSION PC(4),IFLA(2),ICI(2,2)
19515
19516 IF(IJM1.EQ.-1) THEN
19517 DO 116 I=1,15
19518 ETAMI(1,I) = 1.D10
19519 ETAMA(1,I) = -1.D10
19520 ETAMI(2,I) = 1.D10
19521 ETAMA(2,I) = -1.D10
19522 XXMI(1,I) = 1.D0
19523 XXMA(1,I) = 0.D0
19524 XXMI(2,I) = 1.D0
19525 XXMA(2,I) = 0.D0
19526 116 CONTINUE
19527 CALL PHO_HARSCA(IJM1,1)
19528 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19529
19530 RETURN
19531
19532 ELSE IF(IJM1.EQ.-2) THEN
19533
19534C output internal statistics
19535 IF(IDEB(23).GE.1) THEN
19536 WRITE(LO,'(/1X,A)')
19537 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19538 DO 117 I=1,15
19539 WRITE(LO,'(5X,I3,4E13.5)')
19540 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19541 117 CONTINUE
19542 WRITE(LO,'(1X,A)')
19543 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19544 DO 118 I=1,15
19545 WRITE(LO,'(5X,I3,4E13.5)')
19546 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19547 118 CONTINUE
19548 ENDIF
19549 CALL PHO_HARSCA(IJM1,1)
19550 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19551
19552 RETURN
19553 ENDIF
19554
19555 IREJ = 0
19556C debug output
19557 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19558 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19559
19560C get mother data (exchange if first particle is a pomeron)
19561 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19562 JM1 = IJM2
19563 JM2 = IJM1
19564 ELSE
19565 JM1 = IJM1
19566 JM2 = IJM2
19567 ENDIF
19568
19569 NPOSP(1) = JM1
19570 NPOSP(2) = JM2
19571 IDPDG1 = IDHEP(JM1)
19572 IDBAM1 = IMPART(JM1)
19573 IDPDG2 = IDHEP(JM2)
19574 IDBAM2 = IMPART(JM2)
19575
19576C store current status of /POEVT1/
19577 KHPOMS = KHPOM
19578 KSPOMS = KSPOM
19579 KSREGS = KSREG
19580 KHDIRS = KHDIR
19581 NHEPS = NHEP
19582 IPOIS1 = IPOIX1
19583 IPOIS2 = IPOIX2
19584
19585C get nominal masses (photons: VDM assumption)
19586 DELMAS = 0.D0
19587 IF(IDHEP(JM1).EQ.22) THEN
19588 PMASSP(1) = RHOMAS+DELMAS
19589 PVIRTP(1) = PHEP(5,JM1)**2
19590 ELSE
19591 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19592 PVIRTP(1) = 0.D0
19593 ENDIF
19594 IF(IDHEP(JM2).EQ.22) THEN
19595 PMASSP(2) = RHOMAS+DELMAS
19596 PVIRTP(2) = PHEP(5,JM2)**2
19597 ELSE
19598 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19599 PVIRTP(2) = 0.D0
19600 ENDIF
19601
19602C calculate c.m. energy and check kinematics
19603 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19604 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19605 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19606 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19607 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19608
19609 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19610 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19611 & 'energy smaller than two-particle threshold (event rejected)'
19612 CALL PHO_PREVNT(1)
19613 IREJ = 5
19614 GOTO 150
19615 ENDIF
19616 ECMP = SQRT(SS)
19617
19618 IF(IDEB(23).GE.5) THEN
19619 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19620 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19621 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19622 ENDIF
19623
19624C Lorentz transformation into c.m. system
19625 DO 10 I=1,4
19626 GAMBEP(I) = PC(I)/ECMP
19627 10 CONTINUE
19628 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19629 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19630 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19631C rotation angle: particle 1 moves along +z
19632 CODP = PC(3)/PTOT1
19633 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19634 COFP = 1.D0
19635 SIFP = 0.D0
19636 IF(PTOT1*SIDP.GT.1.D-5) THEN
19637 COFP = PC(1)/(SIDP*PTOT1)
19638 SIFP = PC(2)/(SIDP*PTOT1)
19639 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19640 COFP = COFP/ANORF
19641 SIFP = SIFP/ANORF
19642 ENDIF
19643C get CM momentum
19644 XM12 = PMASSP(1)**2
19645 XM22 = PMASSP(2)**2
19646 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19647
19648C find particle combination
19649 II = 0
19650 IF(IDPDG2.EQ.IFPAP(2)) THEN
19651 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19652 ELSE IF(IDPDG2.EQ.990) THEN
19653 IF(IDPDG1.EQ.IFPAP(1)) THEN
19654 II = 2
19655 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19656 II = 3
19657 ELSE IF(IDPDG1.EQ.990) THEN
19658 II = 4
19659 ENDIF
19660 ENDIF
19661 IF(II.EQ.0) THEN
19662 IF(ISWMDL(14).GT.0) THEN
19663 II = 1
19664 ELSE
19665 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19666 & 'invalid particle combination:',IDPDG1,IDPDG2
19667 CALL PHO_ABORT
19668 ENDIF
19669 ENDIF
19670
19671C select parton distribution functions from tables
19672 IF((MHPOM+MHDIR).GT.0) THEN
19673 CALL PHO_ACTPDF(IDPDG1,1)
19674 CALL PHO_ACTPDF(IDPDG2,2)
19675C initialize alpha_s calculation
19676 DUMMY = PHO_ALPHAS(0.D0,-4)
19677 ENDIF
19678
19679C interpolate hard cross sections and rejection weights
19680 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19681 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19682
19683 NTRY = 10
19684
19685C position of first particle added to /POEVT2/
19686 NLOR1 = NHEP+1
19687
19688C ---------------- direct processes -----------------
19689
19690 IF(MHDIR.EQ.1) THEN
19691 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19692 IF(IREJ.EQ.50) RETURN
19693 IF(IREJ.NE.0) GOTO 150
19694C write comments to /POEVT1/
19695 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19696 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19697 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19698 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19699 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19700 & ICA1,ICA2,IPOS,1)
19701 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19702 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19703 & ICA1,ICA2,IPOS,1)
19704 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19705 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19706 & IPOS1,1)
19707 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19708 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19709 & IPOS2,1)
19710
19711C soft spectator partons
19712 ICA1 = 0
19713 ICA2 = 0
19714 ICB1 = 0
19715 ICB2 = 0
19716 IPDF1 = 0
19717 IPDF2 = 0
19718
19719C single resolved: QCD compton scattering
19720C ------------------------------
19721 IF(NPROHD(1).EQ.10) THEN
19722C register hadron remnant
19723 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19724 IPDF2 = 1000*IGRP(2)+ISET(2)
19725 ELSE IF(NPROHD(1).EQ.12) THEN
19726C register hadron remnant
19727 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19728 IPDF1 = 1000*IGRP(1)+ISET(1)
19729
19730C single resolved: photon gluon fusion
19731C ---------------------------
19732 ELSE IF(NPROHD(1).EQ.11) THEN
19733C register hadron remnant
19734 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19735 IPDF2 = 1000*IGRP(2)+ISET(2)
19736 ELSE IF(NPROHD(1).EQ.13) THEN
19737C register hadron remnant
19738 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19739 IPDF1 = 1000*IGRP(1)+ISET(1)
19740
19741C direct process (no remnant)
19742C ----------------------------
19743 ELSE IF(NPROHD(1).EQ.14) THEN
19744
19745 ENDIF
19746
19747C write final high-pt partons to POEVT1
19748 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19749 ICI(1,1) = ICA1
19750 ICI(1,2) = ICA2
19751 ICI(2,1) = ICB1
19752 ICI(2,2) = ICB2
19753 I = 1
19754 IFLA(1) = NINHD(I,1)
19755 IFLA(2) = NINHD(I,2)
19756C initial state radiation
19757 DO 130 K=1,2
19758 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19759 KK = 1
19760 137 CONTINUE
19761 IFLB = IFLISR(K,IPA)
19762 IF(ABS(IFLB).LE.6) THEN
19763C partons
19764 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19765 IF(IFLB.EQ.0) THEN
19766 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19767 & ICI(K,1),ICI(K,2),3)
19768 ELSE IF(IFLB.GT.0) THEN
19769 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19770 & ICI(K,1),ICI(K,2),4)
19771 ELSE
19772 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19773 & IC1,IC2,4)
19774 ENDIF
19775 ELSE
19776 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19777 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19778 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19779 KK = KK+1
19780 GOTO 137
19781 ENDIF
19782 ENDIF
19783 IF(IFLB.EQ.0) THEN
19784 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19785 & IC1,IC2,2)
19786 ELSE
19787 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19788 & ICI(K,1),ICI(K,2),2)
19789 ENDIF
19790 ENDIF
19791 IIFL = IPHO_CNV1(IFLB)
19792 IFLA(K) = IFLA(K)-IFLB
19793 IST = -1
19794 ELSE
19795C other particle
19796 IIFL = IFLB
19797 IC1 = 0
19798 IC2 = 0
19799 IST = 1
19800 ENDIF
19801 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19802 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19803 & IGEN,IC1,IC2,IPOS,1)
19804 135 CONTINUE
19805 130 CONTINUE
19806 ICOLOR(1,IPOS1-2) = ICI(1,1)
19807 ICOLOR(2,IPOS1-2) = ICI(1,2)
19808 ICOLOR(1,IPOS1-1) = ICI(2,1)
19809 ICOLOR(2,IPOS1-1) = ICI(2,2)
19810 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19811 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19812 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
19813 ICOLOR(1,IPOS1) = ICI(1,1)
19814 ICOLOR(2,IPOS1) = ICI(1,2)
19815 ICOLOR(1,IPOS2) = ICI(2,1)
19816 ICOLOR(2,IPOS2) = ICI(2,2)
19817 DO 140 K=1,2
19818 IPA = IPOISR(K,1,I)
19819 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19820 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19821 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19822 140 CONTINUE
19823 ELSE
19824 ICOLOR(1,IPOS1-2) = ICA1
19825 ICOLOR(2,IPOS1-2) = ICA2
19826 ICOLOR(1,IPOS1-1) = ICB1
19827 ICOLOR(2,IPOS1-1) = ICB2
19828 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19829 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19830 & NOUTHD(1,2),ICB1,ICB2)
19831 ICOLOR(1,IPOS1) = ICA1
19832 ICOLOR(2,IPOS1) = ICA2
19833 ICOLOR(1,IPOS2) = ICB1
19834 ICOLOR(2,IPOS2) = ICB2
19835 I = -1
19836 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19837 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19838 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19839 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19840 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19841 ENDIF
19842
19843C assign soft pt to spectators
19844 IF(ISWMDL(18).EQ.0) THEN
19845 IPOS2 = IPOS2-1
19846 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19847 IF(IREJ.NE.0) THEN
19848 IFAIL(26) = IFAIL(26) + 1
19849 GOTO 150
19850 ENDIF
19851
19852 ENDIF
19853
19854C ----------------- resolved processes -------------------
19855
19856C single Reggeon exchange
19857C ----------------------------
19858 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19859C flavours
19860 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19861 IF(IREJ.NE.0) THEN
19862 IFAIL(24) = IFAIL(24)+1
19863 GOTO 150
19864 ENDIF
19865C colors
19866 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19867 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19868 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19869 CALL PHO_SWAPI(ICA1,ICB1)
19870 ENDIF
19871 ECMH = ECMP/2.D0
19872
19873C registration
19874
19875C DPMJET call with special projectile / target
19876 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19877 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19878 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19879 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19880 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19881C default treatment
19882 ELSE
19883 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19884 & -1,IGEN,ICA1,0,IPOS1,1)
19885 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19886 & -1,IGEN,ICB1,0,IPOS2,1)
19887 ENDIF
19888
19889C soft pt assignment
19890 IF(ISWMDL(18).EQ.0) THEN
19891 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19892 IF(IREJ.NE.0) THEN
19893 IFAIL(25) = IFAIL(25) + 1
19894 GOTO 150
19895 ENDIF
19896 ENDIF
19897C
19898C multi Reggeon / Pomeron exchange
19899C----------------------------------------
19900 ELSE
19901C parton configuration
19902
19903 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19904 & MHPAR1,MHPAR2,IREJ)
19905
19906 IF(IREJ.EQ.50) RETURN
19907 IF(IREJ.NE.0) GOTO 150
19908
19909C register particles
19910 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19911 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19912 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19913
19914C register soft partons
19915 IF(IVAL1.NE.0) THEN
19916 IF(IVAL1.LT.0) THEN
19917 IND1 = 3
19918 IVAL1=-IVAL1
19919 ELSE
19920 IND1 = 2
19921 ENDIF
19922 ELSE IF(MSPOM.EQ.0) THEN
19923 IND1 = 4
19924 ELSE
19925 IND1 = 1
19926 ENDIF
19927 IF(IVAL2.NE.0) THEN
19928 IF(IVAL2.LT.0) THEN
19929 IND2 = 3
19930 IVAL2=-IVAL2
19931 ELSE
19932 IND2 = 2
19933 ENDIF
19934 ELSE IF(MSPOM.EQ.0) THEN
19935 IND2 = 4
19936 ELSE
19937 IND2 = 1
19938 ENDIF
19939
19940 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19941 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19942
19943C soft Pomeron final states
19944C -----------------------------------
19945 K = MSPOM+MHPOM+MSREG
19946 DO 50 I=1,MSPOM
19947
19948 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19949 IF(IREJ.NE.0) THEN
19950 IFAIL(8) = IFAIL(8) + 1
19951 GOTO 150
19952 ENDIF
19953C
19954 50 CONTINUE
19955
19956C soft Reggeon final states
19957C -----------------------------------------
19958 DO 75 I=1,MSREG
19959C flavours
19960 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19961 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19962 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19963 ELSE
19964 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19965 ENDIF
19966C colors
19967 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19968 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19969 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19970 & CALL PHO_SWAPI(ICA1,ICB1)
19971C registration
19972 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19973 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19974 & I,IGEN,ICA1,ICA2,IPOS1,1)
19975 IND1 = IND1+1
19976 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19977 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
19978 & I,IGEN,ICB1,ICB2,IPOS2,1)
19979 IND2 = IND2+1
19980
19981 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
19982 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
19983 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
19984
19985C soft pt assignment
19986 IF(ISWMDL(18).EQ.0) THEN
19987 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19988 IF(IREJ.NE.0) THEN
19989 IFAIL(25) = IFAIL(25) + 1
19990 GOTO 150
19991 ENDIF
19992 ENDIF
19993
19994 75 CONTINUE
19995
19996C hard Pomeron final states
19997C ------------------------------------
19998 IND1 = MSPAR1
19999 IND2 = MSPAR2
20000
20001 DO 100 L=1,MHPOM
20002 I = LSIDX(L)
20003
20004 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20005 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20006 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20007 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20008C write comments to /POEVT1/
20009 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20010 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20011 & IFLO1,IFLO2,IPOS,1)
20012 I1 = 8*I-7
20013 IPDF = 1000*IGRP(1)+ISET(1)
20014 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20015 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20016 & ICA1,ICA2,IPOS,1)
20017 IPDF = 1000*IGRP(2)+ISET(2)
20018 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20019 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20020 & ICB1,ICB2,IPOS,1)
20021 I1 = 8*I-3
20022 IPDF = 1000*IGRP(1)+ISET(1)
20023 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20024 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20025 & ICA1,ICA2,IPOS1,1)
20026 IPDF = 1000*IGRP(2)+ISET(2)
20027 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20028 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20029 & ICB1,ICB2,IPOS2,1)
20030
20031C spectator partons belonging to hard interaction
20032 IF(IVAL1.EQ.I) THEN
20033 IVQ = 1
20034 IND = 1
20035 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20036 IVQ = 0
20037 IND = 1
20038 ELSE
20039 IVQ = -1
20040 IND = IND1
20041 ENDIF
20042 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20043 IF(IVQ.LT.0) IND1 = IND1-IUSED
20044 IF(IVAL2.EQ.I) THEN
20045 IVQ = 1
20046 IND = 1
20047 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20048 IVQ = 0
20049 IND = 1
20050 ELSE
20051 IVQ = -1
20052 IND = IND2
20053 ENDIF
20054 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20055 IF(IVQ.LT.0) IND2 = IND2-IUSED
20056C
20057C register hard scattered partons
20058 IF((ISWMDL(8).GE.2)
20059 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20060 ICI(1,1) = ICA1
20061 ICI(1,2) = ICA2
20062 ICI(2,1) = ICB1
20063 ICI(2,2) = ICB2
20064 IFLA(1) = NINHD(I,1)
20065 IFLA(2) = NINHD(I,2)
20066C initial state radiation
20067 DO 230 K=1,2
20068 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20069 KK = 1
20070 237 CONTINUE
20071 IFLB = IFLISR(K,IPA)
20072 IF(ABS(IFLB).LE.6) THEN
20073C partons
20074 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20075 IF(IFLB.EQ.0) THEN
20076 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20077 & ICI(K,1),ICI(K,2),3)
20078 ELSE IF(IFLB.GT.0) THEN
20079 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20080 & ICI(K,1),ICI(K,2),4)
20081 ELSE
20082 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20083 & ICI(K,2),IC1,IC2,4)
20084 ENDIF
20085 ELSE
20086 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20087 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20088 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20089 KK = KK+1
20090 GOTO 237
20091 ENDIF
20092 ENDIF
20093 IF(IFLB.EQ.0) THEN
20094 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20095 & ICI(K,2),IC1,IC2,2)
20096 ELSE
20097 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20098 & ICI(K,1),ICI(K,2),2)
20099 ENDIF
20100 ENDIF
20101 IIFL = IPHO_CNV1(IFLB)
20102 IFLA(K) = IFLA(K)-IFLB
20103 IST = -1
20104 ELSE
20105C other particles
20106 IIFL = IFLB
20107 IC1 = 0
20108 IC2 = 0
20109 IST = 1
20110 ENDIF
20111 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20112 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20113 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20114 235 CONTINUE
20115 230 CONTINUE
20116 ICOLOR(1,IPOS1-2) = ICI(1,1)
20117 ICOLOR(2,IPOS1-2) = ICI(1,2)
20118 ICOLOR(1,IPOS1-1) = ICI(2,1)
20119 ICOLOR(2,IPOS1-1) = ICI(2,2)
20120 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20121 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20122 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20123 ICOLOR(1,IPOS1) = ICI(1,1)
20124 ICOLOR(2,IPOS1) = ICI(1,2)
20125 ICOLOR(1,IPOS2) = ICI(2,1)
20126 ICOLOR(2,IPOS2) = ICI(2,2)
20127 DO 240 K=1,2
20128 IPA = IPOISR(K,1,I)
20129 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20130 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20131 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20132 240 CONTINUE
20133 ELSE
20134 ICOLOR(1,IPOS1-2) = ICA1
20135 ICOLOR(2,IPOS1-2) = ICA2
20136 ICOLOR(1,IPOS1-1) = ICB1
20137 ICOLOR(2,IPOS1-1) = ICB2
20138 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20139 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20140 & NOUTHD(I,2),ICB1,ICB2)
20141 ICOLOR(1,IPOS1) = ICA1
20142 ICOLOR(2,IPOS1) = ICA2
20143 ICOLOR(1,IPOS2) = ICB1
20144 ICOLOR(2,IPOS2) = ICB2
20145 I1 = 8*I-3
20146 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20147 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20148 & ICA1,ICA2,IPOS,1)
20149 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20150 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20151 & ICB1,ICB2,IPOS,1)
20152 ENDIF
20153 100 CONTINUE
20154C end of resolved parton registration
20155 ENDIF
20156
20157 IF(MHDIR+MHPOM.GT.0) THEN
20158
20159 IF(ISWMDL(29).GE.1) THEN
20160C primordial kt of hard scattering
20161 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20162 IF(IREJ.NE.0) THEN
20163 IFAIL(27) = IFAIL(27)+1
20164 GOTO 150
20165 ENDIF
20166 ELSE IF(ISWMDL(24).GE.0) THEN
20167C give "soft" pt only to soft (spectator) partons in hard processes
20168 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20169 IF(IREJ.NE.0) THEN
20170 IFAIL(26) = IFAIL(26)+1
20171 GOTO 150
20172 ENDIF
20173 ENDIF
20174
20175 ENDIF
20176
20177C give "soft" pt to partons in soft Pomerons
20178 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20179 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20180 IF(IREJ.NE.0) THEN
20181 IFAIL(25) = IFAIL(25) + 1
20182 GOTO 150
20183 ENDIF
20184 ENDIF
20185
20186C boost back to lab frame
20187 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20188 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20189 RETURN
20190
20191C rejection treatment
20192 150 CONTINUE
20193 IFAIL(2) = IFAIL(2)+1
20194C reset counters
20195 KSPOM = KSPOMS
20196 KHPOM = KHPOMS
20197 KHDIR = KHDIRS
20198 KSREG = KSREGS
20199C reset mother-daugther relations
20200 JDAHEP(1,JM1) = 0
20201 JDAHEP(2,JM1) = 0
20202 JDAHEP(1,JM2) = 0
20203 JDAHEP(2,JM2) = 0
20204 ISTHEP(JM1) = 1
20205 ISTHEP(JM2) = 1
20206 IPOIX1 = IPOIS1
20207 IPOIX2 = IPOIS2
20208 NHEP = NHEPS
20209C debug
20210 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20211 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20212 & MSPOM,MHPOM,MSREG,MHDIR
20213 RETURN
20214
20215 END
20216
20217*$ CREATE PHO_HARCOL.FOR
20218*COPY PHO_HARCOL
20219CDECK ID>, PHO_HARCOL
20220 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20221 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20222C*********************************************************************
20223C
20224C calculate color flow for hard resolved process
20225C
20226C input: IP1..4 flavour of partons (PDG convention)
20227C V parton subprocess Mandelstam variable V = t/s
20228C (lightcone momenta assumed)
20229C ICA,ICB color labels
20230C MSPR process number
20231C -1 initialization of statistics
20232C -2 output of statistics
20233C
20234C output: ICC,ICD color label of final partons
20235C
20236C (it is possible to use the same variables for in and output)
20237C
20238C**********************************************************************
20239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20240 SAVE
20241
20242C input/output channels
20243 INTEGER LI,LO
20244 COMMON /POINOU/ LI,LO
20245C event debugging information
20246 INTEGER NMAXD
20247 PARAMETER (NMAXD=100)
20248 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20249 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20250 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20251 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20252C model switches and parameters
20253 CHARACTER*8 MDLNA
20254 INTEGER ISWMDL,IPAMDL
20255 DOUBLE PRECISION PARMDL
20256 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20257C names of hard scattering processes
20258 INTEGER Max_pro_1
20259 PARAMETER ( Max_pro_1 = 16 )
20260 CHARACTER*18 PROC
20261 COMMON /POHPRO/ PROC(0:Max_pro_1)
20262
20263 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20264
20265C initialization
20266 IF(MSPR.EQ.-1) THEN
20267 DO 200 I=1,8
20268 DO 210 K=1,5
20269 ICONF(I,K) = 0
20270 210 CONTINUE
20271 IRECN(I,1) = 0
20272 IRECN(I,2) = 0
20273 200 CONTINUE
20274 RETURN
20275C output of statistics
20276 ELSE IF(MSPR.EQ.-2) THEN
20277 IF(IDEB(26).LT.1) RETURN
20278 WRITE(LO,'(/1X,A,/1X,A)')
20279 & 'PHO_HARCOL: sampled color configurations',
20280 & '----------------------------------------'
20281 WRITE(LO,'(6X,A,15X,A)')
20282 & 'diagram color configurations (1-4)','sum'
20283 DO 300 I=1,8
20284 DO 310 K=1,4
20285 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20286 310 CONTINUE
20287 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20288 300 CONTINUE
20289 IF(ISWMDL(11).GE.2) THEN
20290 WRITE(LO,'(/6X,A)')
20291 & 'diagram with / without color re-connection'
20292 DO 320 I=1,8
20293 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20294 320 CONTINUE
20295 ENDIF
20296 RETURN
20297 ENDIF
20298C
20299C gluons: first color positive, quarks second color zero
20300 IF(IP1.EQ.0) THEN
20301 IF(ICA1.LT.0) THEN
20302 I = ICA2
20303 ICA2 = ICA1
20304 ICA1 = I
20305 ENDIF
20306 ELSE
20307 ICA2 = 0
20308 ENDIF
20309 IF(IP2.EQ.0) THEN
20310 IF(ICB1.LT.0) THEN
20311 I = ICB2
20312 ICB2 = ICB1
20313 ICB1 = I
20314 ENDIF
20315 ELSE
20316 ICB2 = 0
20317 ENDIF
20318 IC2 = 0
20319 IC4 = 0
20320C debug output
20321 IF(IDEB(26).GE.15)
20322 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20323 & 'PHO_HARCOL: process',MSPR,
20324 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20325C
20326 IRC = 0
20327 IF(IPAMDL(21).EQ.1) THEN
20328C
20329C soft color re-connection option
20330C
20331 IF(MSPR.EQ.1) THEN
20332C hard g g final state, only g g --> g g
20333 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20334 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20335 IC1 = ICA1
20336 IC2 = ICA2
20337 IC3 = ICB1
20338 IC4 = ICB2
20339 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20340 IRC = 1
20341 GOTO 100
20342 ENDIF
20343 ENDIF
20344 ELSE IF(MSPR.EQ.3) THEN
20345C hard q g final state
20346 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20347 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20348 IC1 = ICA1
20349 IC2 = ICA2
20350 IC3 = ICB1
20351 IC4 = ICB2
20352 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20353 IRC = 1
20354 GOTO 100
20355 ENDIF
20356 ENDIF
20357 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20358C hard q q final state
20359 IF(ICA1.NE.-ICB1) THEN
20360 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20361 IC1 = ICA1
20362 IC2 = ICA2
20363 IC3 = ICB1
20364 IC4 = ICB2
20365 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20366 IRC = 1
20367 GOTO 100
20368 ENDIF
20369 ENDIF
20370 ENDIF
20371 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20372 ENDIF
20373C
20374 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20375C
20376C large Nc limit of all graphs
20377C
20378 IF(MSPR.EQ.1) THEN
20379C g g --> g g
20380 IF(DT_RNDM(V).GT.0.5D0) THEN
20381 IC1 = ICB1
20382 IC2 = ICA2
20383 IC3 = ICA1
20384 IC4 = ICB2
20385 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20386 ELSE
20387 IC1 = ICA1
20388 IC2 = ICB2
20389 IC3 = ICB1
20390 IC4 = ICA2
20391 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20392 ENDIF
20393 ELSE IF(MSPR.EQ.2) THEN
20394C q qb --> g g
20395 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20396 IF(ICA1.LT.0) THEN
20397 IC1 = I1
20398 IC2 = ICA1
20399 IC3 = ICB1
20400 IC4 = I2
20401 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20402 ELSE
20403 IC1 = ICA1
20404 IC2 = I2
20405 IC3 = I1
20406 IC4 = ICB1
20407 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20408 ENDIF
20409 ELSE IF(MSPR.EQ.3) THEN
20410C q g --> q g
20411 IF(DT_RNDM(V).LT.0.5D0) THEN
20412 IF(IP1+IP2.GT.0) THEN
20413 IC1 = ICB1
20414 IC2 = ICA2
20415 IC3 = ICA1
20416 IC4 = ICB2
20417 ELSE IF(IP1.LT.0) THEN
20418 IC1 = ICB2
20419 IC3 = ICB1
20420 IC4 = ICA1
20421 ELSE
20422 IC1 = ICA1
20423 IC2 = ICB1
20424 IC3 = ICA2
20425 ENDIF
20426 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20427 ELSE
20428 IF(IP1.GT.0) THEN
20429 CALL PHO_HARCOR(-ICA1,ICB2)
20430 IC1 = ICA1
20431 IC3 = ICB1
20432 IC4 = -ICA1
20433 ELSE IF(IP2.GT.0) THEN
20434 CALL PHO_HARCOR(-ICB1,ICA2)
20435 IC1 = ICA1
20436 IC2 = -ICB1
20437 IC3 = ICB1
20438 ELSE IF(IP1.LT.0) THEN
20439 CALL PHO_HARCOR(-ICA1,ICB1)
20440 IC1 = ICA1
20441 IC3 = -ICA1
20442 IC4 = ICB2
20443 ELSE IF(IP2.LT.0) THEN
20444 CALL PHO_HARCOR(-ICB1,ICA1)
20445 IC1 = -ICB1
20446 IC2 = ICA2
20447 IC3 = ICB1
20448 ENDIF
20449 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20450 ENDIF
20451 ELSE IF(MSPR.EQ.4) THEN
20452C g g --> q qb
20453 IC1 = ICA1
20454 IC3 = ICB2
20455 CALL PHO_HARCOR(-ICB1,ICA2)
20456 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20457 IF(IP3*IC1.LT.0) THEN
20458 I = IC1
20459 IC1 = IC3
20460 IC3 = I
20461 ENDIF
20462 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20463 ELSE IF(MSPR.EQ.5) THEN
20464C q qb --> q qb
20465 IF(DT_RNDM(V).LT.0.5D0) THEN
20466 IF(ICA1*IP3.LT.0) THEN
20467 IC1 = ICB1
20468 IC3 = ICA1
20469 ELSE
20470 IC1 = ICA1
20471 IC3 = ICB1
20472 ENDIF
20473 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20474 ELSE
20475 IF(ICA1*IP3.LT.0) THEN
20476 IC1 = -ICA1
20477 IC3 = ICA1
20478 ELSE
20479 IC1 = ICA1
20480 IC3 = -ICA1
20481 ENDIF
20482 CALL PHO_HARCOR(-ICA1,ICB1)
20483 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20484 ENDIF
20485 ELSE IF(MSPR.EQ.6) THEN
20486C q qb --> qp qbp
20487 IF(ICA1*IP3.LT.0) THEN
20488 IC1 = ICB1
20489 IC3 = ICA1
20490 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20491 ELSE
20492 IC1 = ICA1
20493 IC3 = ICB1
20494 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20495 ENDIF
20496 ELSE IF(MSPR.EQ.7) THEN
20497C q q --> q q
20498 IF(DT_RNDM(V).LT.0.5D0) THEN
20499 IC1 = ICA1
20500 IC3 = ICB1
20501 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20502 ELSE
20503 IC1 = ICB1
20504 IC3 = ICA1
20505 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20506 ENDIF
20507 ELSE IF(MSPR.EQ.8) THEN
20508C q qp --> q qp
20509 IF(IP1*IP2.GT.0) THEN
20510 IF(IP3.EQ.IP1) THEN
20511 IC1 = ICB1
20512 IC3 = ICA1
20513 ELSE
20514 IC1 = ICA1
20515 IC3 = ICB1
20516 ENDIF
20517 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20518 ELSE
20519 IF(ICA1*IP3.LT.0) THEN
20520 IC1 = -ICA1
20521 IC3 = ICA1
20522 ELSE
20523 IC1 = ICA1
20524 IC3 = -ICA1
20525 ENDIF
20526 CALL PHO_HARCOR(-ICA1,ICB1)
20527 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20528 ENDIF
20529 ELSE
20530C unknown process
20531 WRITE(LO,'(/1X,A,I3)')
20532 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20533 CALL PHO_ABORT
20534 ENDIF
20535C
20536 ELSE
20537C
20538C color flow according to QCD leading order matrix element
20539C
20540 U = -(1.D0+V)
20541 IF(MSPR.EQ.1) THEN
20542C g g --> g g
20543 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20544 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20545 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20546 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20547 PCS = 0.D0
20548 DO 110 I=1,3
20549 PCS = PCS+PC(I)
20550 IF(XI.LT.PCS) GOTO 120
20551 110 CONTINUE
20552 120 CONTINUE
20553 IF(I.EQ.1) THEN
20554 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20555 IF(DT_RNDM(V).GT.0.5D0) THEN
20556 IC1 = I1
20557 IC2 = ICA2
20558 IC3 = ICB1
20559 IC4 = I2
20560 CALL PHO_HARCOR(-ICB2,ICA1)
20561 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20562 ELSE
20563 IC1 = ICA1
20564 IC2 = I2
20565 IC3 = I1
20566 IC4 = ICB2
20567 CALL PHO_HARCOR(-ICB1,ICA2)
20568 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20569 ENDIF
20570 ELSE IF(I.EQ.2) THEN
20571 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20572 IF(DT_RNDM(U).GT.0.5D0) THEN
20573 IC1 = ICB1
20574 IC2 = I2
20575 IC3 = I1
20576 IC4 = ICA2
20577 CALL PHO_HARCOR(-ICB2,ICA1)
20578 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20579 ELSE
20580 IC1 = I1
20581 IC2 = ICB2
20582 IC3 = ICA1
20583 IC4 = I2
20584 CALL PHO_HARCOR(-ICB1,ICA2)
20585 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20586 ENDIF
20587 ELSE
20588 IF(DT_RNDM(V).GT.0.5D0) THEN
20589 IC1 = ICB1
20590 IC2 = ICA2
20591 IC3 = ICA1
20592 IC4 = ICB2
20593 ELSE
20594 IC1 = ICA1
20595 IC2 = ICB2
20596 IC3 = ICB1
20597 IC4 = ICA2
20598 ENDIF
20599 ENDIF
20600 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20601 ELSE IF(MSPR.EQ.2) THEN
20602C q qb --> g g
20603 PC(1) = U/V-2.D0*U**2
20604 PC(2) = V/U-2.D0*V**2
20605 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20606 XI = (PC(1)+PC(2))*DT_RNDM(U)
20607 IF(XI.LT.PC(1)) THEN
20608 IF(ICA1.GT.0) THEN
20609 IC1 = ICA1
20610 IC2 = I2
20611 IC3 = I1
20612 IC4 = ICB1
20613 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20614 ELSE
20615 IC1 = I1
20616 IC2 = ICA1
20617 IC3 = ICB1
20618 IC4 = I2
20619 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20620 ENDIF
20621 ELSE
20622 IF(ICA1.GT.0) THEN
20623 IC1 = I1
20624 IC2 = ICB1
20625 IC3 = ICA1
20626 IC4 = I2
20627 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20628 ELSE
20629 IC1 = ICB1
20630 IC2 = I2
20631 IC3 = I1
20632 IC4 = ICA1
20633 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20634 ENDIF
20635 ENDIF
20636 ELSE IF(MSPR.EQ.3) THEN
20637C q g --> q g
20638 PC(1) = 2.D0*(U/V)**2-U
20639 PC(2) = 2.D0/V**2-1.D0/U
20640 XI = (PC(1)+PC(2))*DT_RNDM(V)
20641 IF(XI.LT.PC(1)) THEN
20642 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20643 IF(IP1.GT.0) THEN
20644 IC1 = I1
20645 IC3 = ICB1
20646 IC4 = I2
20647 CALL PHO_HARCOR(-ICA1,ICB2)
20648 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20649 ELSE IF(IP1.LT.0) THEN
20650 IC1 = I2
20651 IC3 = I1
20652 IC4 = ICB2
20653 CALL PHO_HARCOR(-ICA1,ICB1)
20654 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20655 ELSE IF(IP2.GT.0) THEN
20656 IC1 = ICA1
20657 IC2 = I2
20658 IC3 = I1
20659 CALL PHO_HARCOR(-ICB1,ICA2)
20660 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20661 ELSE
20662 IC1 = I1
20663 IC2 = ICA2
20664 IC3 = I2
20665 CALL PHO_HARCOR(-ICB1,ICA1)
20666 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20667 ENDIF
20668 ELSE
20669 IF(IP1.GT.0) THEN
20670 IC1 = ICB1
20671 IC3 = ICA1
20672 IC4 = ICB2
20673 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20674 ELSE IF(IP1.LT.0) THEN
20675 IC1 = ICB2
20676 IC3 = ICB1
20677 IC4 = ICA1
20678 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20679 ELSE IF(IP2.GT.0) THEN
20680 IC1 = ICB1
20681 IC2 = ICA2
20682 IC3 = ICA1
20683 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20684 ELSE
20685 IC1 = ICA1
20686 IC2 = ICB1
20687 IC3 = ICA2
20688 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20689 ENDIF
20690 ENDIF
20691 ELSE IF(MSPR.EQ.4) THEN
20692C g g --> q qb
20693 PC(1) = U/V-2.D0*U**2
20694 PC(2) = V/U-2.D0*V**2
20695 XI = (PC(1)+PC(2))*DT_RNDM(U)
20696 IF(XI.LT.PC(1)) THEN
20697 IF(IP3.GT.0) THEN
20698 IC1 = ICA1
20699 IC3 = ICB2
20700 CALL PHO_HARCOR(-ICB1,ICA2)
20701 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20702 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20703 ELSE
20704 IC1 = ICA2
20705 IC3 = ICB1
20706 CALL PHO_HARCOR(-ICB2,ICA1)
20707 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20708 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20709 ENDIF
20710 ELSE
20711 IF(IP3.GT.0) THEN
20712 IC1 = ICB1
20713 IC3 = ICA2
20714 CALL PHO_HARCOR(-ICB2,ICA1)
20715 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20716 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20717 ELSE
20718 IC1 = ICB2
20719 IC3 = ICA1
20720 CALL PHO_HARCOR(-ICB1,ICA2)
20721 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20722 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20723 ENDIF
20724 ENDIF
20725 ELSE IF(MSPR.EQ.5) THEN
20726C q qb --> q qb
20727 PC(1) = (1.D0+U**2)/V**2
20728 PC(2) = (V**2+U**2)
20729 XI = (PC(1)+PC(2))*DT_RNDM(V)
20730 IF(XI.LT.PC(1)) THEN
20731 CALL PHO_HARCOR(-ICB1,ICA1)
20732 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20733 IF(IP3.GT.0) THEN
20734 IC1 = I1
20735 IC3 = I2
20736 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20737 ELSE
20738 IC1 = I2
20739 IC3 = I1
20740 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20741 ENDIF
20742 ELSE
20743 IF(IP3.GT.0) THEN
20744 IC1 = MAX(ICA1,ICB1)
20745 IC3 = MIN(ICA1,ICB1)
20746 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20747 ELSE
20748 IC1 = MIN(ICA1,ICB1)
20749 IC3 = MAX(ICA1,ICB1)
20750 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20751 ENDIF
20752 ENDIF
20753 ELSE IF(MSPR.EQ.6) THEN
20754C q qb --> qp qpb
20755 IF(IP3.GT.0) THEN
20756 IC1 = MAX(ICA1,ICB1)
20757 IC3 = MIN(ICA1,ICB1)
20758 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20759 ELSE
20760 IC1 = MIN(ICA1,ICB1)
20761 IC3 = MAX(ICA1,ICB1)
20762 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20763 ENDIF
20764 ELSE IF(MSPR.EQ.7) THEN
20765C q q --> q q
20766 PC(1) = (1.D0+U**2)/V**2
20767 PC(2) = (1.D0+V**2)/U**2
20768 XI = (PC(1)+PC(2))*DT_RNDM(U)
20769 IF(XI.LT.PC(1)) THEN
20770 IC1 = ICB1
20771 IC3 = ICA1
20772 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20773 ELSE
20774 IC1 = ICA1
20775 IC3 = ICB1
20776 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20777 ENDIF
20778 ELSE IF(MSPR.EQ.8) THEN
20779C q qp --> q qp
20780 IF(IP1*IP2.LT.0) THEN
20781 CALL PHO_HARCOR(-ICB1,ICA1)
20782 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20783 IF(IP1.GT.0) THEN
20784 IC1 = I1
20785 IC3 = I2
20786 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20787 ELSE
20788 IC1 = I2
20789 IC3 = I1
20790 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20791 ENDIF
20792 ELSE
20793 IC1 = ICB1
20794 IC3 = ICA1
20795 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20796 ENDIF
20797
20798 ELSE IF(MSPR.EQ.10) THEN
20799C gam q --> q g
20800 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20801 IF(IP3.EQ.0) THEN
20802 CALL PHO_SWAPI(IC1,IC3)
20803 CALL PHO_SWAPI(IC2,IC4)
20804 ENDIF
20805 ELSE IF(MSPR.EQ.11) THEN
20806C gam g --> q q
20807 IC1 = ICB1
20808 IC3 = ICB2
20809 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20810 ELSE IF(MSPR.EQ.12) THEN
20811C q gam --> q g
20812 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20813 IF(IP3.EQ.0) THEN
20814 CALL PHO_SWAPI(IC1,IC3)
20815 CALL PHO_SWAPI(IC2,IC4)
20816 ENDIF
20817 ELSE IF(MSPR.EQ.13) THEN
20818C g gam --> q q
20819 IC1 = ICA1
20820 IC3 = ICA2
20821 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20822 ELSE IF(MSPR.EQ.14) THEN
20823 IF(ABS(IP3).GT.12) THEN
20824 IC1 = 0
20825 IC3 = 0
20826 ELSE
20827 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20828 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20829 ENDIF
20830 ELSE
20831C unknown process
20832 WRITE(LO,'(/1X,A,I3)')
20833 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20834 CALL PHO_ABORT
20835 ENDIF
20836 ENDIF
20837C
20838 100 CONTINUE
20839C debug output
20840 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20841 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20842C color connection?
20843* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20844* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20845* & .OR.(IC2.EQ.0))) THEN
20846C color exchange?
20847* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20848* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20849* IF(IRC.NE.1) THEN
20850* WRITE(LO,'(1X,A,I10,I3)')
20851* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20852* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20853* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20854* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20855* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20856* ENDIF
20857* IRC = 0
20858* ENDIF
20859* ENDIF
20860* IF(IRC.EQ.1) THEN
20861* WRITE(LO,'(1X,A,I10,I3)')
20862* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20863* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20864* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20865* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20866* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20867* ENDIF
20868C
20869 ICC1 = IC1
20870 ICC2 = IC2
20871 ICD1 = IC3
20872 ICD2 = IC4
20873
20874 END
20875
20876*$ CREATE PHO_HARCOR.FOR
20877*COPY PHO_HARCOR
20878CDECK ID>, PHO_HARCOR
20879 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20880C***********************************************************************
20881C
20882C substituite color in /POEVT2/
20883C
20884C input: ICOLD old color
20885C ICNEW new color
20886C
20887C***********************************************************************
20888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20889 SAVE
20890
20891C input/output channels
20892 INTEGER LI,LO
20893 COMMON /POINOU/ LI,LO
20894C standard particle data interface
20895 INTEGER NMXHEP
20896 PARAMETER (NMXHEP=4000)
20897 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20898 DOUBLE PRECISION PHEP,VHEP
20899 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20900 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20901 & VHEP(4,NMXHEP)
20902C extension to standard particle data interface (PHOJET specific)
20903 INTEGER IMPART,IPHIST,ICOLOR
20904 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20905
20906 DO 100 I=NHEP,3,-1
20907 IF(ISTHEP(I).EQ.-1) THEN
20908 IF(ICOLOR(1,I).EQ.ICOLD) THEN
20909 ICOLOR(1,I) = ICNEW
20910 RETURN
20911 ELSE IF(IDHEP(I).EQ.21) THEN
20912 IF(ICOLOR(2,I).EQ.ICOLD) THEN
20913 ICOLOR(2,I) = ICNEW
20914 RETURN
20915 ENDIF
20916 ENDIF
20917* ELSE IF(ISTHEP(I).EQ.20) THEN
20918* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
ecf67adb 20919* WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
9aaba0d6 20920* ICOLOR(1,I) = -ICNEW
20921* RETURN
20922* ELSE IF(IDHEP(I).EQ.21) THEN
20923* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
ecf67adb 20924* WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
9aaba0d6 20925* ICOLOR(2,I) = -ICNEW
20926* RETURN
20927* ENDIF
20928* ENDIF
20929 ENDIF
20930 100 CONTINUE
20931 END
20932
20933*$ CREATE PHO_HARREM.FOR
20934*COPY PHO_HARREM
20935CDECK ID>, PHO_HARREM
20936 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20937 & IUSED,IREJ)
20938C***********************************************************************
20939C
20940C sample color structure for initial quark/gluon of hard scattering
20941C and write hadron remnant to /POEVT1/
20942C
20943C input: JM1,2 index of mother particle in POEVT1
20944C IGEN mother particle production process
20945C IHPOS hard pomeron number
20946C INDXH index of hard parton
20947C positive for labels 1
20948C negative for labels 2
20949C IVAL 1 hard valence parton
20950C 0 hard sea parton connected by color flow with
20951C valence quarks
20952C -1 hard sea parton independent off valence
20953C quarks
20954C INDXS index of soft partons needed
20955C
20956C output: IC1,IC2 color label of initial parton
20957C IUSED number of soft X values used
20958C IREJ rejection flag
20959C
20960C**********************************************************************
20961 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20962 SAVE
20963
20964 PARAMETER ( TINY = 1.D-10 )
20965
20966C input/output channels
20967 INTEGER LI,LO
20968 COMMON /POINOU/ LI,LO
20969C event debugging information
20970 INTEGER NMAXD
20971 PARAMETER (NMAXD=100)
20972 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20973 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20974 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20975 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20976C model switches and parameters
20977 CHARACTER*8 MDLNA
20978 INTEGER ISWMDL,IPAMDL
20979 DOUBLE PRECISION PARMDL
20980 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20981C data of c.m. system of Pomeron / Reggeon exchange
20982 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
20983 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
20984 & SIDP,CODP,SIFP,COFP
20985 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
20986 & SIDP,CODP,SIFP,COFP,NPOSP(2),
20987 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
20988C obsolete cut-off information
20989 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
20990 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
20991C light-cone x fractions and c.m. momenta of soft cut string ends
20992 INTEGER MAXSOF
20993 PARAMETER ( MAXSOF = 50 )
20994 INTEGER IJSI2,IJSI1
20995 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
20996 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
20997 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
20998 & IJSI1(MAXSOF),IJSI2(MAXSOF)
20999C hard scattering data
21000 INTEGER MSCAHD
21001 PARAMETER ( MSCAHD = 50 )
21002 INTEGER LSCAHD,LSC1HD,LSIDX,
21003 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21004 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21005 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21006 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21007 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21008 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21009 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21010 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21011 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21012C standard particle data interface
21013 INTEGER NMXHEP
21014 PARAMETER (NMXHEP=4000)
21015 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21016 DOUBLE PRECISION PHEP,VHEP
21017 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21018 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21019 & VHEP(4,NMXHEP)
21020C extension to standard particle data interface (PHOJET specific)
21021 INTEGER IMPART,IPHIST,ICOLOR
21022 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21023C internal rejection counters
21024 INTEGER NMXJ
21025 PARAMETER (NMXJ=60)
21026 CHARACTER*10 REJTIT
21027 INTEGER IFAIL
21028 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21029
21030 IREJ = 0
21031
21032 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21033
21034 IF(INDXH.GT.0) THEN
21035 IJH = IPHO_CNV1(NINHD(INDXH,1))
21036 ELSE
21037 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21038 ENDIF
21039C direct process (photon or pomeron)
21040 IUSED = 0
21041 IC1 = 0
21042 IC2 = 0
21043 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21044
21045 IHP = 100*ABS(IHPOS)
21046 IVSW = 1
21047***************************************
21048* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21049***************************************
21050
21051 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21052 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21053 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21054
21055C quark
21056C****************************************************************
21057
21058 IF(IJH.NE.21) THEN
21059
21060C valence quark engaged in hard scattering
21061 IF(IVAL.EQ.1) THEN
21062 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21063 IF(IREJ.NE.0) THEN
21064 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21065 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21066 return
21067 ENDIF
21068 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21069 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21070 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21071 I = ICA1
21072 ICA1 = ICB1
21073 ICB1 = I
21074 ENDIF
21075C remnant of hadron
21076 IF(INDXH.GT.0) THEN
21077 P1 = PSOFT1(1,INDXS)
21078 P2 = PSOFT1(2,INDXS)
21079 P3 = PSOFT1(3,INDXS)
21080 P4 = PSOFT1(4,INDXS)
21081 IJSI1(INDXS) = IREM
21082 ELSE
21083 P1 = PSOFT2(1,INDXS)
21084 P2 = PSOFT2(2,INDXS)
21085 P3 = PSOFT2(3,INDXS)
21086 P4 = PSOFT2(4,INDXS)
21087 IJSI2(INDXS) = IREM
21088 ENDIF
21089C registration
21090 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21091 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21092 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21093 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21094 & IREM,IPOS,SIGN(INDXS,INDXH)
21095 IUSED = 1
21096
21097C sea quark engaged in hard scattering, valence quarks treated
21098 ELSE IF(IVAL.EQ.0) THEN
21099 IF(INDXH.GT.0) THEN
21100 E1 = PSOFT1(4,INDXS)
21101 E2 = PSOFT1(4,INDXS+1)
21102 ELSE
21103 E1 = PSOFT2(4,INDXS)
21104 E2 = PSOFT2(4,INDXS+1)
21105 ENDIF
21106 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21107 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21108 IF(DT_RNDM(P1).LT.0.5D0) THEN
21109 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21110 ELSE
21111 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21112 ENDIF
21113 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21114 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21115 I = ICA1
21116 ICA1 = ICB1
21117 ICB1 = I
21118 ENDIF
21119 IF(INDXH.GT.0) THEN
21120 P1 = PSOFT1(1,INDXS)
21121 P2 = PSOFT1(2,INDXS)
21122 P3 = PSOFT1(3,INDXS)
21123 P4 = PSOFT1(4,INDXS)
21124 IJSI1(INDXS) = IVFL1
21125 ELSE
21126 P1 = PSOFT2(1,INDXS)
21127 P2 = PSOFT2(2,INDXS)
21128 P3 = PSOFT2(3,INDXS)
21129 P4 = PSOFT2(4,INDXS)
21130 IJSI2(INDXS) = IVFL1
21131 ENDIF
21132C registration
21133 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21134 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21135 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21136 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21137 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21138C
21139 IF(INDXH.GT.0) THEN
21140 P1 = PSOFT1(1,INDXS+1)
21141 P2 = PSOFT1(2,INDXS+1)
21142 P3 = PSOFT1(3,INDXS+1)
21143 P4 = PSOFT1(4,INDXS+1)
21144 IJSI1(INDXS+1) = IVFL2
21145 ELSE
21146 P1 = PSOFT2(1,INDXS+1)
21147 P2 = PSOFT2(2,INDXS+1)
21148 P3 = PSOFT2(3,INDXS+1)
21149 P4 = PSOFT2(4,INDXS+1)
21150 IJSI2(INDXS+1) = IVFL2
21151 ENDIF
21152C registration
21153 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21154 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21155 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21156 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21157 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21158C
21159 IF(IJH.LT.0) THEN
21160 ICB1 = ICC2
21161 ICA1 = ICC1
21162 ELSE
21163 ICB1 = ICC1
21164 ICA1 = ICC2
21165 ENDIF
21166 IF(INDXH.GT.0) THEN
21167 P1 = PSOFT1(1,INDXS+2)
21168 P2 = PSOFT1(2,INDXS+2)
21169 P3 = PSOFT1(3,INDXS+2)
21170 P4 = PSOFT1(4,INDXS+2)
21171 IJSI1(INDXS+2) = -IJH
21172 ELSE
21173 P1 = PSOFT2(1,INDXS+2)
21174 P2 = PSOFT2(2,INDXS+2)
21175 P3 = PSOFT2(3,INDXS+2)
21176 P4 = PSOFT2(4,INDXS+2)
21177 IJSI2(INDXS+2) = -IJH
21178 ENDIF
21179C registration
21180 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21181 & IHP,IGEN,ICA1,0,IPOS,1)
21182 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21183 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21184 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21185 IUSED = 3
21186C
21187C sea quark engaged in hard scattering, valences treated separately
21188 ELSE IF(IVAL.EQ.-1) THEN
21189 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21190 IF(IJH.GT.0) THEN
21191 ICC1 = ICB1
21192 ICB1 = ICA1
21193 ICA1 = ICC1
21194 ENDIF
21195 IF(INDXH.GT.0) THEN
21196 P1 = PSOFT1(1,INDXS)
21197 P2 = PSOFT1(2,INDXS)
21198 P3 = PSOFT1(3,INDXS)
21199 P4 = PSOFT1(4,INDXS)
21200 IJSI1(INDXS) = -IJH
21201 ELSE
21202 P1 = PSOFT2(1,INDXS)
21203 P2 = PSOFT2(2,INDXS)
21204 P3 = PSOFT2(3,INDXS)
21205 P4 = PSOFT2(4,INDXS)
21206 IJSI2(INDXS) = -IJH
21207 ENDIF
21208C registration
21209 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21210 & IHP,IGEN,ICA1,0,IPOS,1)
21211 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21212 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21213 & -IJH,IPOS,SIGN(INDXS,INDXH)
21214 IUSED = 1
21215 ELSE
21216 WRITE(LO,'(1X,A,2I5)')
21217 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21218 & IVAL,IJH
21219 CALL PHO_ABORT
21220 ENDIF
21221C
21222 IC1 = ICB1
21223 IC2 = 0
21224C
21225C gluon
21226C****************************************************************
21227C
21228C gluon from valence quarks
21229 ELSE
21230 IF(IVAL.EQ.1) THEN
21231C purely gluonic pomeron remnant
21232 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21233 IF(INDXH.GT.0) THEN
21234 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21235 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21236 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21237 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21238 IJSI1(INDXS) = 0
21239 ELSE
21240 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21241 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21242 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21243 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21244 IJSI2(INDXS) = 0
21245 ENDIF
21246 IFL1 = 21
21247 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21248 IF(DT_RNDM(P2).LT.0.5D0) THEN
21249 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21250 ELSE
21251 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21252 ENDIF
21253C registration
21254 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21255 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21256 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21257 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21258 & IFL1,IPOS,SIGN(INDXS,INDXH)
21259 IUSED = 2
21260C valence quark remnant
21261 ELSE
21262 IF(INDXH.GT.0) THEN
21263 E1 = PSOFT1(4,INDXS)
21264 E2 = PSOFT1(4,INDXS+1)
21265 ELSE
21266 E1 = PSOFT2(4,INDXS)
21267 E2 = PSOFT2(4,INDXS+1)
21268 ENDIF
21269 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21270 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21271 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21272 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21273 I = ICA1
21274 ICA1 = ICB1
21275 ICB1 = I
21276 ENDIF
21277 IF(DT_RNDM(P2).LT.0.5D0) THEN
21278 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21279 ELSE
21280 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21281 ENDIF
21282C remnant of hadron
21283 IF(INDXH.GT.0) THEN
21284 P1 = PSOFT1(1,INDXS)
21285 P2 = PSOFT1(2,INDXS)
21286 P3 = PSOFT1(3,INDXS)
21287 P4 = PSOFT1(4,INDXS)
21288 IJSI1(INDXS) = IFL1
21289 ELSE
21290 P1 = PSOFT2(1,INDXS)
21291 P2 = PSOFT2(2,INDXS)
21292 P3 = PSOFT2(3,INDXS)
21293 P4 = PSOFT2(4,INDXS)
21294 IJSI2(INDXS) = IFL1
21295 ENDIF
21296C registration
21297 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21298 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21299 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21300 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21301 & IFL1,IPOS,SIGN(INDXS,INDXH)
21302C
21303 IF(INDXH.GT.0) THEN
21304 P1 = PSOFT1(1,INDXS+1)
21305 P2 = PSOFT1(2,INDXS+1)
21306 P3 = PSOFT1(3,INDXS+1)
21307 P4 = PSOFT1(4,INDXS+1)
21308 IJSI1(INDXS+1) = IFL2
21309 ELSE
21310 P1 = PSOFT2(1,INDXS+1)
21311 P2 = PSOFT2(2,INDXS+1)
21312 P3 = PSOFT2(3,INDXS+1)
21313 P4 = PSOFT2(4,INDXS+1)
21314 IJSI2(INDXS+1) = IFL2
21315 ENDIF
21316C registration
21317 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21318 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21319 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21320 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21321 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21322 IUSED = 2
21323 ENDIF
21324C
21325C gluon from sea quarks connected with valence quarks
21326 ELSE IF(IVAL.EQ.0) THEN
21327 IF(INDXH.GT.0) THEN
21328 E1 = PSOFT1(4,INDXS)
21329 E2 = PSOFT1(4,INDXS+1)
21330 ELSE
21331 E1 = PSOFT2(4,INDXS)
21332 E2 = PSOFT2(4,INDXS+1)
21333 ENDIF
21334 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21335 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21336 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21337 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21338 I = ICA1
21339 ICA1 = ICB1
21340 ICB1 = I
21341 ENDIF
21342 IF(DT_RNDM(P3).LT.0.5D0) THEN
21343 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21344 ELSE
21345 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21346 ENDIF
21347C remnant of hadron
21348 IF(INDXH.GT.0) THEN
21349 P1 = PSOFT1(1,INDXS)
21350 P2 = PSOFT1(2,INDXS)
21351 P3 = PSOFT1(3,INDXS)
21352 P4 = PSOFT1(4,INDXS)
21353 IJSI1(INDXS) = IFL1
21354 ELSE
21355 P1 = PSOFT2(1,INDXS)
21356 P2 = PSOFT2(2,INDXS)
21357 P3 = PSOFT2(3,INDXS)
21358 P4 = PSOFT2(4,INDXS)
21359 IJSI2(INDXS) = IFL1
21360 ENDIF
21361C registration
21362 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21363 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21364 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21365 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21366 & IFL1,IPOS,SIGN(INDXS,INDXH)
21367C
21368 IF(INDXH.GT.0) THEN
21369 P1 = PSOFT1(1,INDXS+1)
21370 P2 = PSOFT1(2,INDXS+1)
21371 P3 = PSOFT1(3,INDXS+1)
21372 P4 = PSOFT1(4,INDXS+1)
21373 IJSI1(INDXS+1) = IFL2
21374 ELSE
21375 P1 = PSOFT2(1,INDXS+1)
21376 P2 = PSOFT2(2,INDXS+1)
21377 P3 = PSOFT2(3,INDXS+1)
21378 P4 = PSOFT2(4,INDXS+1)
21379 IJSI2(INDXS+1) = IFL2
21380 ENDIF
21381C registration
21382 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21383 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21384 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21385 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21386 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21387 IF(IPAMDL(18).EQ.0) THEN
21388C sea quark pair
21389 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21390 IF(ICC1.GT.0) THEN
21391 IFL1 = ABS(IFL1)
21392 IFL2 = -IFL1
21393 ELSE
21394 IFL1 = -ABS(IFL1)
21395 IFL2 = -IFL1
21396 ENDIF
21397 IF(DT_RNDM(P4).LT.0.5D0) THEN
21398 ICB1 = ICC2
21399 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21400 ELSE
21401 ICA1 = ICC1
21402 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21403 ENDIF
21404 IF(INDXH.GT.0) THEN
21405 P1 = PSOFT1(1,INDXS+2)
21406 P2 = PSOFT1(2,INDXS+2)
21407 P3 = PSOFT1(3,INDXS+2)
21408 P4 = PSOFT1(4,INDXS+2)
21409 IJSI1(INDXS+2) = IFL1
21410 ELSE
21411 P1 = PSOFT2(1,INDXS+2)
21412 P2 = PSOFT2(2,INDXS+2)
21413 P3 = PSOFT2(3,INDXS+2)
21414 P4 = PSOFT2(4,INDXS+2)
21415 IJSI2(INDXS+2) = IFL1
21416 ENDIF
21417C registration
21418 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21419 & IHP,IGEN,ICA1,0,IPOS,1)
21420 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21421 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21422 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21423C
21424 IF(INDXH.GT.0) THEN
21425 P1 = PSOFT1(1,INDXS+3)
21426 P2 = PSOFT1(2,INDXS+3)
21427 P3 = PSOFT1(3,INDXS+3)
21428 P4 = PSOFT1(4,INDXS+3)
21429 IJSI1(INDXS+3) = IFL2
21430 ELSE
21431 P1 = PSOFT2(1,INDXS+3)
21432 P2 = PSOFT2(2,INDXS+3)
21433 P3 = PSOFT2(3,INDXS+3)
21434 P4 = PSOFT2(4,INDXS+3)
21435 IJSI2(INDXS+3) = IFL2
21436 ENDIF
21437C registration
21438 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21439 & IHP,IGEN,ICB1,0,IPOS,1)
21440 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21441 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21442 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21443 IUSED = 4
21444 ELSE
21445 IUSED = 2
21446 ENDIF
21447C
21448C gluon from independent sea quarks
21449 ELSE IF(IVAL.EQ.-1) THEN
21450 IF(IPAMDL(18).EQ.0) THEN
21451 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21452 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21453 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21454 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21455 I = ICA1
21456 ICA1 = ICB1
21457 ICB1 = I
21458 ENDIF
21459 IF(DT_RNDM(P1).LT.0.5D0) THEN
21460 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21461 ELSE
21462 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21463 ENDIF
21464C remainder of hadron
21465 IF(INDXH.GT.0) THEN
21466 P1 = PSOFT1(1,INDXS)
21467 P2 = PSOFT1(2,INDXS)
21468 P3 = PSOFT1(3,INDXS)
21469 P4 = PSOFT1(4,INDXS)
21470 IJSI1(INDXS) = IFL1
21471 ELSE
21472 P1 = PSOFT2(1,INDXS)
21473 P2 = PSOFT2(2,INDXS)
21474 P3 = PSOFT2(3,INDXS)
21475 P4 = PSOFT2(4,INDXS)
21476 IJSI2(INDXS) = IFL1
21477 ENDIF
21478C registration
21479 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21480 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21481 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21482 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21483 & IFL1,IPOS,SIGN(INDXS,INDXH)
21484C remnant of sea
21485 IF(INDXH.GT.0) THEN
21486 P1 = PSOFT1(1,INDXS-1)
21487 P2 = PSOFT1(2,INDXS-1)
21488 P3 = PSOFT1(3,INDXS-1)
21489 P4 = PSOFT1(4,INDXS-1)
21490 IJSI1(INDXS-1) = IFL2
21491 ELSE
21492 P1 = PSOFT2(1,INDXS-1)
21493 P2 = PSOFT2(2,INDXS-1)
21494 P3 = PSOFT2(3,INDXS-1)
21495 P4 = PSOFT2(4,INDXS-1)
21496 IJSI2(INDXS-1) = IFL2
21497 ENDIF
21498C registration
21499 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21500 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21501 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21502 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21503 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21504 IUSED = 2
21505 ELSE
21506 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21507 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21508 & 'PHO_HARREM: no spectator added:(INDXS)',
21509 & SIGN(INDXS,INDXH)
21510 IUSED = 0
21511 ENDIF
21512C
21513 ELSE
21514 WRITE(LO,'(1X,A,2I5)')
21515 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21516 & IVAL,IJH
21517 CALL PHO_ABORT
21518 ENDIF
21519 IC1 = ICC1
21520 IC2 = ICC2
21521 ENDIF
21522 END
21523
21524*$ CREATE PHO_HARDIR.FOR
21525*COPY PHO_HARDIR
21526CDECK ID>, PHO_HARDIR
21527 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21528 & IREJ)
21529C**********************************************************************
21530C
21531C parton orientated formulation of direct scattering processes
21532C
21533C input:
21534C
21535C output: II particle combination (1..4)
21536C IVAL1,2 0 no valence quarks engaged
21537C 1 valence quarks engaged
21538C MSPAR1,2 number of realized soft partons
21539C MHPAR1,2 number of realized hard partons
21540C IREJ 1 failure
21541C 0 success
21542C
21543C**********************************************************************
21544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21545 SAVE
21546
21547C input/output channels
21548 INTEGER LI,LO
21549 COMMON /POINOU/ LI,LO
21550C event debugging information
21551 INTEGER NMAXD
21552 PARAMETER (NMAXD=100)
21553 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21554 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21555 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21556 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21557C model switches and parameters
21558 CHARACTER*8 MDLNA
21559 INTEGER ISWMDL,IPAMDL
21560 DOUBLE PRECISION PARMDL
21561 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21562C hard scattering parameters used for most recent hard interaction
21563 INTEGER NFbeta,NF
21564 DOUBLE PRECISION ALQCD2,BQCD
21565 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21566C data of c.m. system of Pomeron / Reggeon exchange
21567 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21568 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21569 & SIDP,CODP,SIFP,COFP
21570 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21571 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21572 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21573C obsolete cut-off information
21574 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21575 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21576C hard cross sections and MC selection weights
21577 INTEGER Max_pro_2
21578 PARAMETER ( Max_pro_2 = 16 )
21579 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21580 & MH_acc_1,MH_acc_2
21581 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21582 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21583 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21584 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21585 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21586 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21587C data on most recent hard scattering
21588 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21589 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21590 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21591 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21592 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21593 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21594 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21595 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21596 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21597C light-cone x fractions and c.m. momenta of soft cut string ends
21598 INTEGER MAXSOF
21599 PARAMETER ( MAXSOF = 50 )
21600 INTEGER IJSI2,IJSI1
21601 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21602 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21603 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21604 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21605C hard scattering data
21606 INTEGER MSCAHD
21607 PARAMETER ( MSCAHD = 50 )
21608 INTEGER LSCAHD,LSC1HD,LSIDX,
21609 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21610 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21611 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21612 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21613 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21614 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21615 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21616 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21617 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21618C internal rejection counters
21619 INTEGER NMXJ
21620 PARAMETER (NMXJ=60)
21621 CHARACTER*10 REJTIT
21622 INTEGER IFAIL
21623 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21624
21625 DIMENSION P1(4),P2(4),PD1(-6:6)
21626
21627 PARAMETER ( TINY = 1.D-10 )
21628
21629 ITRY = 0
21630 NTRY = 10
21631 LSC1HD = 0
21632 LSIDX(1) = 1
21633
21634C check phase space
21635 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21636 IFAIL(18) = IFAIL(18)+1
21637 IREJ = 50
21638 RETURN
21639 ENDIF
21640
21641 AS = (PARMDL(160+II)/ECMP)**2
21642 AH = (2.D0*PTWANT/ECMP)**2
21643
21644 ALNS = LOG(AS)
21645 ALNH = LOG(AH)
21646
21647 XMAX = MAX(TINY,1.D0-AS)
21648 Z1MAX = LOG(XMAX)
21649 Z1DIF = Z1MAX-ALNH
21650C
21651C main loop to select hard and soft parton kinematics
21652C -----------------------------------------------------
21653 120 CONTINUE
21654 IREJ = 0
21655 ITRY = ITRY+1
21656 LSC1HD = LSC1HD+1
21657 IF(ITRY.GT.1) THEN
21658 IFAIL(17) = IFAIL(17)+1
21659 IF(ITRY.GE.NTRY) THEN
21660 IREJ = 1
21661 GOTO 450
21662 ENDIF
21663 ENDIF
21664 LINE = 0
21665 LSCAHD = 0
21666 XSS1 = 0.D0
21667 XSS2 = 0.D0
21668 MSPAR1 = 0
21669 MSPAR2 = 0
21670
21671C select hard V,X
21672 CALL PHO_HARSCA(1,II)
21673 XSS1 = XSS1+X1
21674 XSS2 = XSS2+X2
21675C debug output
21676 IF(IDEB(25).GE.20) THEN
21677 WRITE(LO,'(1X,A,2E12.4,2I5)')
21678 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21679 & AS,XMAX,MSPR,ITRY
21680 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21681 & X1,X2,XSS1,XSS2
21682 ENDIF
21683
21684 IF(MSPR.LE.11) THEN
21685 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21686 ELSE IF(MSPR.LE.13) THEN
21687 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21688 ENDIF
21689
21690C fill /POHSLT/
21691 LSCAHD = 1
21692 LSIDX(1) = 1
21693 XHD(1,1) = X1
21694 XHD(1,2) = X2
21695 X0HD(1,1) = X1
21696 X0HD(1,2) = X2
21697 VHD(1) = V
21698 ETAHD(1,1) = ETAC
21699 ETAHD(1,2) = ETAD
21700 PTHD(1) = PT
21701 Q2SCA(1,1) = QQPD
21702 Q2SCA(1,2) = QQPD
21703 NPROHD(1) = MSPR
21704 NBRAHD(1,1)= IDPDG1
21705 NBRAHD(1,2)= IDPDG2
21706 DO 45 I=1,4
21707 PPH(I,1) = PHI1(I)
21708 PPH(I,2) = PHI2(I)
21709 PPH(4+I,1) = PHO1(I)
21710 PPH(4+I,2) = PHO2(I)
21711 45 CONTINUE
21712C valence quarks
21713 IVAL1 = IV1
21714 IVAL2 = IV2
21715 PDFVA(1,1) = 0.D0
21716 PDFVA(1,2) = 0.D0
21717C parton flavours
21718 IF(MSPR.LE.11) THEN
21719 NINHD(1,1) = IDPDG1
21720 NINHD(1,2) = IB
21721 PDFVA(1,2) = PDF2(IB)
21722 KHDIR = 1
21723 ELSE IF(MSPR.LE.13) THEN
21724 NINHD(1,1) = IA
21725 PDFVA(1,1) = PDF1(IA)
21726 NINHD(1,2) = IDPDG2
21727 KHDIR = 2
21728 ELSE
21729 NINHD(1,1) = IDPDG1
21730 NINHD(1,2) = IDPDG2
21731 KHDIR = 3
21732 ENDIF
21733 N0INHD(1,1) = NINHD(1,1)
21734 N0INHD(1,2) = NINHD(1,2)
21735 N0IVAL(1,1) = IVAL1
21736 N0IVAL(1,2) = IVAL2
21737 NOUTHD(1,1) = IC
21738 NOUTHD(1,2) = ID
21739
21740C reweight according to photon virtuality
21741 IF(MSPR.NE.14) THEN
21742 IF(IPAMDL(115).GE.1) THEN
21743 WGX = 1.D0
21744 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21745 QQPD = Q2SCA(1,2)
21746 IF(IPAMDL(115).EQ.1) THEN
21747 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21748 WGX = 0.D0
21749 ELSE
21750 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21751 & /LOG(QQPD/PARMDL(144))
21752 ENDIF
21753 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21754 ELSE IF(IPAMDL(115).EQ.2) THEN
21755 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21756 WGX = PD1(IB)/PDFVA(1,2)
21757 ENDIF
21758 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21759 & .AND.(IDPDG1.EQ.22)) THEN
21760 QQPD = Q2SCA(1,1)
21761 IF(IPAMDL(115).EQ.1) THEN
21762 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21763 WGX = 0.D0
21764 ELSE
21765 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21766 & /LOG(QQPD/PARMDL(144))
21767 ENDIF
21768 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21769 ELSE IF(IPAMDL(115).EQ.2) THEN
21770 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21771 WGX = PD1(IA)/PDFVA(1,1)
21772 ENDIF
21773 ENDIF
21774
21775 IF(IDEB(25).GE.25)
21776 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21777 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21778 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21779
21780 IF(WGX.LT.DT_RNDM(WGX)) THEN
21781 IREJ = 50
21782 RETURN
21783 ENDIF
21784
21785 IF(WGX.GT.1.01D0)
21786 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21787 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21788 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21789
21790 ENDIF
21791 ENDIF
21792
21793C generate ISR
21794 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21795 IF(IPAMDL(109).EQ.1) THEN
21796 Q2H = PARMDL(93)*PT**2
21797 ELSE
21798 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21799 ENDIF
21800 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
21801 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
21802 DO 42 J=1,4
21803 P1(J) = PPH(4+J,1)
21804 P2(J) = PPH(4+J,2)
21805 42 CONTINUE
21806 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21807 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21808 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21809 XSS1 = XSS1+XISR1-XHD(1,1)
21810 XSS2 = XSS2+XISR2-XHD(1,2)
21811 NINHD(1,1) = IFL1
21812 NINHD(1,2) = IFL2
21813 XHD(1,1) = XISR1
21814 XHD(1,2) = XISR2
21815 ELSE
21816 IFL1 = NINHD(1,1)
21817 IFL2 = NINHD(1,2)
21818 ENDIF
21819 NIVAL(1,1) = IVAL1
21820 NIVAL(1,2) = IVAL2
21821
21822C add photon/hadron remnant
21823
21824C incoming gluon
21825 IF(IFL2.EQ.0) THEN
21826 XMAXX = 1.D0 - XSS2 - AS
21827 XMAXH = MIN(XMAXX,PARMDL(44))
21828 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21829 IVAL2 = 1
21830 MSPAR1 = 0
21831 MSPAR2 = 2
21832 MHPAR1 = 1
21833 MHPAR2 = 1
21834 ELSE IF(IFL1.EQ.0) THEN
21835 XMAXX = 1.D0 - XSS1 - AS
21836 XMAXH = MIN(XMAXX,PARMDL(44))
21837 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21838 IVAL1 = 1
21839 MSPAR1 = 2
21840 MSPAR2 = 0
21841 MHPAR1 = 1
21842 MHPAR2 = 1
21843
21844C incoming quark
21845 ELSE IF(ABS(IFL2).LE.12) THEN
21846 IF(IVAL2.EQ.1) THEN
21847 XS2(1) = 1.D0 - XSS2
21848 MSPAR1 = 0
21849 MSPAR2 = 1
21850 MHPAR1 = 1
21851 MHPAR2 = 1
21852 ELSE
21853 XMAXX = 1.D0 - XSS2 - AS
21854 XMAXH = MIN(XMAXX,PARMDL(44))
21855 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21856 MSPAR1 = 0
21857 MSPAR2 = 3
21858 MHPAR1 = 1
21859 MHPAR2 = 1
21860 ENDIF
21861 ELSE IF(ABS(IFL1).LE.12) THEN
21862 IF(IVAL1.EQ.1) THEN
21863 XS1(1) = 1.D0 - XSS1
21864 MSPAR1 = 1
21865 MSPAR2 = 0
21866 MHPAR1 = 1
21867 MHPAR2 = 1
21868 ELSE
21869 XMAXX = 1.D0 - XSS1 - AS
21870 XMAXH = MIN(XMAXX,PARMDL(44))
21871 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21872 MSPAR1 = 3
21873 MSPAR2 = 0
21874 MHPAR1 = 1
21875 MHPAR2 = 1
21876 ENDIF
21877
21878C double direct process
21879 ELSE IF(MSPR.EQ.14) THEN
21880 MSPAR1 = 0
21881 MSPAR2 = 0
21882 MHPAR1 = 1
21883 MHPAR2 = 1
21884
21885C unknown process
21886 ELSE
21887 WRITE(LO,'(/1X,A,I3/)')
21888 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21889 CALL PHO_ABORT
21890 ENDIF
21891
21892 IF(IREJ.NE.0) THEN
21893 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21894 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21895 GOTO 120
21896 ENDIF
21897
21898C soft particle momenta
21899 IF(MSPAR1.GT.0) THEN
21900 DO 50 I=1,MSPAR1
21901 PSOFT1(1,I) = 0.D0
21902 PSOFT1(2,I) = 0.D0
21903 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21904 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21905 50 CONTINUE
21906 ENDIF
21907 IF(MSPAR2.GT.0) THEN
21908 DO 55 I=1,MSPAR2
21909 PSOFT2(1,I) = 0.D0
21910 PSOFT2(2,I) = 0.D0
21911 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21912 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21913 55 CONTINUE
21914 ENDIF
21915C process counting
21916 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21917 KSOFT = MAX(MSPAR1,MSPAR2)
21918 KHARD = MAX(MHPAR1,MHPAR2)
21919C debug output
21920 IF(IDEB(25).GE.10) THEN
21921 WRITE(LO,'(/1X,A,2I3,3I5)')
21922 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21923 & IVAL1,IVAL2,MSPR,ITRY,NTRY
21924 IF(MSPAR1.GT.0) THEN
21925 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21926 DO 105 I=1,MSPAR1
21927 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21928 105 CONTINUE
21929 ENDIF
21930 IF(MSPAR2.GT.0) THEN
21931 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21932 DO 106 I=1,MSPAR2
21933 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21934 106 CONTINUE
21935 ENDIF
21936 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21937 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21938 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
21939 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21940 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21941 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21942 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
21943 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21944 ENDIF
21945 RETURN
21946
21947 450 CONTINUE
21948 IFAIL(16) = IFAIL(16)+1
21949 IF(IDEB(25).GE.2) THEN
21950 WRITE(LO,'(1X,A,3I5)')
21951 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21952 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21953 IF(IDEB(25).GE.5) THEN
21954 CALL PHO_PREVNT(0)
21955 ELSE
21956 CALL PHO_PREVNT(-1)
21957 ENDIF
21958 ENDIF
21959
21960 END
21961
21962*$ CREATE PHO_POMSCA.FOR
21963*COPY PHO_POMSCA
21964CDECK ID>, PHO_POMSCA
21965 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21966 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21967C**********************************************************************
21968C
21969C parton orientated formulation of soft and hard inelastic events
21970C
21971C
21972C input: II particle combiantion (1..4)
21973C MSPOM number of soft pomerons
21974C MHPOM number of semihard pomerons
21975C MSREG number of soft reggeons
21976C
21977C output: IVAL1,2 0 no valence quark engaged
21978C otherwise: position of valence quark engaged
21979C neg.number: gluon connected to valence quark
21980C by color flow
21981C MSPAR1,2 number of realized soft partons
21982C MHPAR1,2 number of realized hard partons
21983C IREJ 1 failure
21984C 0 success
21985C
21986C**********************************************************************
21987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21988 SAVE
21989
21990 PARAMETER (TINY = 1.D-30 )
21991
21992C input/output channels
21993 INTEGER LI,LO
21994 COMMON /POINOU/ LI,LO
21995C event debugging information
21996 INTEGER NMAXD
21997 PARAMETER (NMAXD=100)
21998 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21999 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22000 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22001 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22002C model switches and parameters
22003 CHARACTER*8 MDLNA
22004 INTEGER ISWMDL,IPAMDL
22005 DOUBLE PRECISION PARMDL
22006 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22007C general process information
22008 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22009 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22010C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22011 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22012 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22013 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22014 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22015C event weights and generated cross section
22016 INTEGER IPOWGC,ISWCUT,IVWGHT
22017 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22018 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22019 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22020C hard cross sections and MC selection weights
22021 INTEGER Max_pro_2
22022 PARAMETER ( Max_pro_2 = 16 )
22023 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22024 & MH_acc_1,MH_acc_2
22025 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22026 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22027 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22028 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22029 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22030 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22031C hard scattering parameters used for most recent hard interaction
22032 INTEGER NFbeta,NF
22033 DOUBLE PRECISION ALQCD2,BQCD
22034 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22035C data of c.m. system of Pomeron / Reggeon exchange
22036 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22037 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22038 & SIDP,CODP,SIFP,COFP
22039 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22040 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22041 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22042C obsolete cut-off information
22043 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22044 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22045C some hadron information, will be deleted in future versions
22046 INTEGER NFS
22047 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22048 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22049C data on most recent hard scattering
22050 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22051 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22052 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22053 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22054 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22055 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22056 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22057 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22058 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22059C light-cone x fractions and c.m. momenta of soft cut string ends
22060 INTEGER MAXSOF
22061 PARAMETER ( MAXSOF = 50 )
22062 INTEGER IJSI2,IJSI1
22063 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22064 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22065 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22066 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22067C hard scattering data
22068 INTEGER MSCAHD
22069 PARAMETER ( MSCAHD = 50 )
22070 INTEGER LSCAHD,LSC1HD,LSIDX,
22071 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22072 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22073 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22074 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22075 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22076 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22077 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22078 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22079 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22080C table of particle indices for recursive PHOJET calls
22081 INTEGER MAXIPX
22082 PARAMETER ( MAXIPX = 100 )
22083 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22084 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22085 & IPOIX1,IPOIX2,IPOIX3
22086C internal rejection counters
22087 INTEGER NMXJ
22088 PARAMETER (NMXJ=60)
22089 CHARACTER*10 REJTIT
22090 INTEGER IFAIL
22091 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22092
22093 DIMENSION P1(4),P2(4),PD1(-6:6)
22094
22095 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22096 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22097
22098 ITRY = 0
22099 NTRY = 10
22100 IREJ = 0
22101 INMAX = 10
22102 MHARD = MHPOM
22103
22104C phase space limitation (single hard valence-valence quark scattering)
22105 IF(MHPOM.GT.0) THEN
22106 Emin = 2.D0*PTWANT + 0.2D0
22107 IF(ECMP.LT.Emin) THEN
22108 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22109 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22110 IREJ = 50
22111 IFAIL(6) = IFAIL(6) + 1
22112 RETURN
22113 ENDIF
22114 ENDIF
22115
22116 SAS = PARMDL(160+II)/ECMP
22117 SAH = 2.D0*PTWANT/ECMP
22118 AS = SAS**2
22119 AH = SAH**2
22120
22121C save energy for leading particle effect
22122 XMAXP1 = 1.D0
22123 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22124 XMAXP2 = 1.D0
22125 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22126
22127C
22128C main loop to select hard and soft parton kinematics
22129C -----------------------------------------------------
22130 IFAIL(31) = IFAIL(31)+MHARD
22131 20 CONTINUE
22132 IREJ = 0
22133 IHARD = 0
22134 LSC1HD = 0
22135 ITRY = ITRY+1
22136 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22137 IF(ITRY.GE.NTRY) THEN
22138 IREJ = 1
22139 GOTO 450
22140 ENDIF
22141 LINE = 0
22142 LSCAHD = 0
22143 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22144 XSS1 = MAX(0.D0,1.D0-XPSUB)
22145 XSS2 = MAX(0.D0,1.D0-XTSUB)
22146 ELSE
22147 XSS1 = 0.D0
22148 XSS2 = 0.D0
22149 ENDIF
22150 22 continue
22151
22152C partons needed to construct soft/hard interactions
22153 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22154 MSPAR2 = MSPAR1
22155 MHPAR1 = MHPOM
22156 MHPAR2 = MHPOM
22157
22158C number of strings
22159 MSCHA = 2*MSPOM+MSREG
22160 MHCHA = 2*MHPOM
22161
22162 KSOFT = MSCHA
22163 KHARD = MHCHA
22164
22165C check actual phase space limit
22166 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22167 IF(XX.GE.1.D0) THEN
22168 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22169 & 'PHO_POMSCA: internal kin. rejection ',
22170 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22171 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22172 if(MSPOM+MSREG+MHPOM.gt.1) then
22173 if(MSREG.gt.0) then
22174 MSREG = MSREG-1
22175 else if(MSPOM.gt.0) THEN
22176 MSPOM = MSPOM-1
22177 else if(MHPOM.gt.1) then
22178 MHPOM = MHPOM-1
22179 endif
22180 goto 22
22181 endif
22182 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22183 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22184 IREJ = 50
22185 IFAIL(6) = IFAIL(6) + 1
22186 RETURN
22187 ENDIF
22188
22189 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22190 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22191
22192C very low energy phase space restriction
22193 if(MHARD.gt.0) then
22194 if((XMAXX1*XMAXX2.le.AH)) then
22195 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22196 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22197 IREJ = 50
22198 IFAIL(6) = IFAIL(6) + 1
22199 RETURN
22200 endif
22201 endif
22202
22203 AS = MAX(AS,PSOMIN/PCMP)
22204 ALNS = LOG(AS)
22205 ALNH = LOG(AH)
22206 Z1MAX = LOG(XMAXX1)
22207 Z2MAX = LOG(XMAXX2)
22208 Z1DIF = Z1MAX+Z2MAX-ALNH
22209 Z2DIF = Z1DIF
22210 PTMAX = 0.D0
22211C
22212C select hard parton momenta
22213C ------------------- begin of inner loop -------------------
22214 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22215 IF(MHARD.GT.MSCAHD) THEN
22216 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22217 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22218 IREJ = 1
22219 RETURN
22220 ENDIF
22221 DO 11 NN=1,MHARD
22222C
22223C generate one resolved hard scattering
22224C
22225C high-pt option
22226 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22227 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22228 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22229 XSCUT = HSig(9)
22230 AHS = AH
22231 ALNHS = ALNH
22232 Z1DIFS = Z1DIF
22233 Z2DIFS = Z2DIF
22234 AH = (2.D0*PTWANT/ECMP)**2
22235 ALNH = LOG(AH)
22236 Z1DIF = Z1MAX+Z2MAX-ALNH
22237 Z2DIF = Z1DIF
22238 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22239 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22240 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22241 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22242 IREJ = 5
22243 RETURN
22244 ENDIF
22245 CALL PHO_HARSCA(2,II)
22246 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22247 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22248 AH = AHS
22249 ALNH = ALNHS
22250 Z1DIF = Z1DIFS
22251 Z2DIF = Z2DIFS
22252 IPOWGC(4+II) = IPOWGC(4+II)+1
22253 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22254C minimum bias option
22255 ELSE
22256 CALL PHO_HARSCA(2,II)
22257 ENDIF
22258
22259C fill /POHSLT/
22260 LSIDX(NN) = NN
22261 LSCAHD = NN
22262 XHD(NN,1) = X1
22263 XHD(NN,2) = X2
22264 X0HD(NN,1) = X1
22265 X0HD(NN,2) = X2
22266 VHD(NN) = V
22267 ETAHD(NN,1) = ETAC
22268 ETAHD(NN,2) = ETAD
22269 PTHD(NN) = PT
22270 NPROHD(NN) = MSPR
22271 Q2SCA(NN,1) = QQPD
22272 Q2SCA(NN,2) = QQPD
22273 PDFVA(NN,1) = PDF1(IA)
22274 PDFVA(NN,2) = PDF2(IB)
22275 NINHD(NN,1) = IA
22276 NINHD(NN,2) = IB
22277 N0INHD(NN,1) = IA
22278 N0INHD(NN,2) = IB
22279 NIVAL(NN,1) = IV1
22280 NIVAL(NN,2) = IV2
22281 N0IVAL(NN,1) = IV1
22282 N0IVAL(NN,2) = IV2
22283 NOUTHD(NN,1) = IC
22284 NOUTHD(NN,2) = ID
22285 NBRAHD(NN,1) = IDPDG1
22286 NBRAHD(NN,2) = IDPDG2
22287 I3 = 8*(NN-1)
22288 I4 = 8*(NN-1)+4
22289 DO 50 I=1,4
22290 PPH(I3+I,1) = PHI1(I)
22291 PPH(I3+I,2) = PHI2(I)
22292 PPH(I4+I,1) = PHO1(I)
22293 PPH(I4+I,2) = PHO2(I)
22294 50 CONTINUE
22295
22296 11 CONTINUE
22297
22298C sort according to pt-hat
22299 DO 12 NN=1,MHARD
22300 PTMX = PTHD(LSIDX(NN))
22301 IPTM = NN
22302 DO 13 I=NN+1,MHARD
22303 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22304 IPTM = I
22305 PTMX = PTHD(LSIDX(I))
22306 ENDIF
22307 13 CONTINUE
22308 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22309 12 CONTINUE
22310 IPTM = LSIDX(1)
22311
22312C copy partons, generate ISR
22313 DO 15 L=1,MHARD
22314 NN = LSIDX(L)
22315 XSSS1 = XSS1+XHD(NN,1)
22316 XSSS2 = XSS2+XHD(NN,2)
22317C debug output
22318 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22319 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22320 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22321C check phase space
22322 IF( (XSSS1.GT.XMAXX1)
22323 & .OR.(XSSS2.GT.XMAXX2)
22324 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22325 IF(IHARD.EQ.0) THEN
22326 IF(ISWMDL(2).NE.1) GOTO 20
22327 MHPOM = 0
22328 MSPOM = 1
22329 MSREG = 0
22330 ENDIF
22331 GOTO 199
22332 ENDIF
22333
22334C reweight according to photon virtuality
22335 IF(IPAMDL(115).GE.1) THEN
22336 QQPD = Q2SCA(NN,1)
22337 WGX = 1.D0
22338 IF(IDPDG1.EQ.22) THEN
22339 IF(IPAMDL(115).EQ.1) THEN
22340 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22341 WG1 = 0.D0
22342 ELSE
22343 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22344 & /LOG(QQPD/PARMDL(144))
22345 ENDIF
22346 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22347 ELSE IF(IPAMDL(115).EQ.2) THEN
22348 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22349 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22350 ENDIF
22351 WGX = WG1
22352 ENDIF
22353 QQPD = Q2SCA(NN,2)
22354 IF(IDPDG2.EQ.22) THEN
22355 IF(IPAMDL(115).EQ.1) THEN
22356 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22357 WG1 = 0.D0
22358 ELSE
22359 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22360 & /LOG(QQPD/PARMDL(144))
22361 ENDIF
22362 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22363 ELSE IF(IPAMDL(115).EQ.2) THEN
22364 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22365 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22366 ENDIF
22367 WGX = WGX*WG1
22368 ENDIF
22369
22370 IF(IDEB(24).GE.25)
22371 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22372 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22373 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22374
22375 IF(WGX.LT.DT_RNDM(WGX)) THEN
22376 IF(L.EQ.1) THEN
22377 IREJ = 50
22378 RETURN
22379 ELSE
22380 GOTO 199
22381 ENDIF
22382 ENDIF
22383
22384 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22385 & 'PHO_POMSCA: ',
22386 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22387 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22388
22389 ENDIF
22390
22391C generate ISR
22392 IF((ISWMDL(8).GE.2)
22393 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22394 IF(IPAMDL(109).EQ.1) THEN
22395 Q2H = PARMDL(93)*PTHD(NN)**2
22396 ELSE
22397 Q2H = -PARMDL(93)*VHD(NN)
22398 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22399 ENDIF
22400 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22401 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22402 I3 = 8*NN-4
22403 DO 42 J=1,4
22404 P1(J) = PPH(I3+J,1)
22405 P2(J) = PPH(I3+J,2)
22406 42 CONTINUE
22407 IF(IDEB(24).GE.10)
22408 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22409 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22410 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22411 J = NN
22412 IF(L.EQ.1) J = -NN
22413 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22414 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22415 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22416 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22417 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22418 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22419 NINHD(NN,1) = IFL1
22420 NINHD(NN,2) = IFL2
22421 XHD(NN,1) = XISR1
22422 XHD(NN,2) = XISR2
22423 ENDIF
22424
22425C check phase space
22426 IF( (XSSS1.GT.XMAXX1)
22427 & .OR.(XSSS2.GT.XMAXX2)
22428 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22429 IF(IHARD.EQ.0) THEN
22430 IF(ISWMDL(2).NE.1) GOTO 20
22431 MHPOM = 0
22432 MSPOM = 1
22433 MSREG = 0
22434 ENDIF
22435 GOTO 199
22436 ENDIF
22437
22438C leave energy for leading particle effect
22439 IF((IHARD.GT.0).AND.
22440 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22441 GOTO 199
22442 endif
22443
22444C hard scattering accepted
22445 IHARD = IHARD+1
22446 XSS1 = XSSS1
22447 XSS2 = XSSS2
22448 IFAIL(31) = IFAIL(31)-1
22449
22450 15 CONTINUE
22451
22452C ------------------- end of inner (hard) loop -------------------
22453 199 CONTINUE
22454
22455 MHPOM = IHARD
22456 MHPAR1 = IHARD
22457 MHPAR2 = IHARD
22458
22459C count valences involved in hard scattering
22460 IVAL1 = 0
22461 IVAL2 = 0
22462 DO 17 L=1,IHARD
22463 NN = LSIDX(L)
22464 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22465 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22466 17 CONTINUE
22467
22468 IQUA1 = 0
22469 IQUA2 = 0
22470 IVGLU1 = 0
22471 IVGLU2 = 0
22472 DO 18 L=1,IHARD
22473 NN = LSIDX(L)
22474
22475C photon, pomeron valences
22476 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22477 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22478 NIVAL(NN,1) = 1
22479 IVAL1 = NN
22480 ENDIF
22481 ENDIF
22482 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22483 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22484 NIVAL(NN,2) = 1
22485 IVAL2 = NN
22486 ENDIF
22487 ENDIF
22488
22489C total number of quarks
22490 IF(NINHD(NN,1).NE.0) THEN
22491 IQUA1 = IQUA1+1
22492 ELSE IF(IVGLU1.EQ.0) THEN
22493 IVGLU1 = NN
22494 ENDIF
22495 IF(NINHD(NN,2).NE.0) THEN
22496 IQUA2 = IQUA2+1
22497 ELSE IF(IVGLU2.EQ.0) THEN
22498 IVGLU2 = NN
22499 ENDIF
22500 18 CONTINUE
22501
22502C gluons emitted by valence quarks
22503 VALPRO = 1.D0
22504 IF(II.EQ.1) VALPRO = VALPRG(1)
22505 IVQ1 = 1
22506 IVG1 = 0
22507 IVAL1 = MAX(IVAL1,0)
22508 IF(IVAL1.EQ.0) THEN
22509 IVQ1 = 0
22510 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22511 IVAL1 = -IVGLU1
22512 IVG1 = 1
22513 ENDIF
22514 ENDIF
22515 VALPRO = 1.D0
22516 IF(II.EQ.1) VALPRO = VALPRG(2)
22517 IVQ2 = 1
22518 IVG2 = 0
22519 IVAL2 = MAX(IVAL2,0)
22520 IF(IVAL2.EQ.0) THEN
22521 IVQ2 = 0
22522 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22523 IVAL2 = -IVGLU2
22524 IVG2 = 1
22525 ENDIF
22526 ENDIF
22527 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22528C debug output
22529 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22530 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22531 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22532
22533C select soft X values
22534 25 CONTINUE
22535C number of soft/remnant quarks
22536 IF(MSPOM.EQ.0) THEN
22537 IF(IPAMDL(18).EQ.0) THEN
22538 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22539 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22540 ELSE
22541 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22542 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22543 ENDIF
22544 ELSE
22545 IF(IPAMDL(18).EQ.0) THEN
22546 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22547 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22548 ELSE
22549 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22550 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22551 ENDIF
22552 ENDIF
22553C debug output
22554 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22555 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22556 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22557
22558 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22559 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22560 I1 = IVQ1
22561 I2 = IVQ2
22562 IF(IVAL1.LE.0) I1 = 0
22563 IF(IVAL2.LE.0) I2 = 0
22564 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22565 MSDIFF = 2*MSPOM
22566 ELSE
22567 MSDIFF = 2*MAX(0,MSPOM-1)
22568 ENDIF
22569 MSG1 = MSPAR1
22570 MSG2 = MSPAR2
22571 MSM1 = MSPAR1-MSDIFF
22572 MSM2 = MSPAR2-MSDIFF
22573 XMAXH1 = MIN(XMAX1,PARMDL(44))
22574 XMAXH2 = MIN(XMAX2,PARMDL(44))
22575 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22576 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22577
22578C correct for proper simulation of high pt tail
22579 IF(IREJ.NE.0) THEN
22580 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22581 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22582 & MSPOM,MHPOM,I1,I2
22583 IF(MSPOM*MHPOM.GT.0) THEN
22584 MSPOM = MSPOM-1
22585 GOTO 25
22586 ELSE IF(MSPOM.GT.1) THEN
22587 MSPOM = MSPOM-1
22588 GOTO 25
22589 ELSE IF(MHPOM.GT.1) THEN
22590 IHARD = IHARD-1
22591 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22592 & .AND.(IPROCE.EQ.1)) THEN
22593 XSS1 = MAX(0.D0,1.D0-XPSUB)
22594 XSS2 = MAX(0.D0,1.D0-XTSUB)
22595 ELSE
22596 XSS1 = 0.D0
22597 XSS2 = 0.D0
22598 ENDIF
22599 DO 103 K=1,IHARD
22600 I = LSIDX(K)
22601 XSS1 = XSS1+ XHD(I,1)
22602 XSS2 = XSS2+ XHD(I,2)
22603 103 CONTINUE
22604 GOTO 199
22605 ENDIF
22606 IREJ = 4
22607 GOTO 450
22608 ENDIF
22609C accepted
22610 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22611 MSPAR1 = MSG1
22612 MSPAR2 = MSG2
22613C ------------ kinematics sampled ---------------
22614C debug output
22615 IF(IDEB(24).GE.10) THEN
22616 WRITE(LO,'(1X,A,I3)')
22617 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22618 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22619 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22620 104 CONTINUE
22621 ENDIF
22622 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22623
22624C end of loop
22625 XS1(1) = 1.D0 - XSS1
22626 XS2(1) = 1.D0 - XSS2
22627
22628C process counting
22629 DO 30 N=1,LSCAHD
22630 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22631 30 CONTINUE
22632
22633C soft particle momenta
22634 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22635 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22636 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22637 IREJ = 1
22638 RETURN
22639 ENDIF
22640 DO 55 I=1,MSPAR1
22641 PSOFT1(1,I) = 0.D0
22642 PSOFT1(2,I) = 0.D0
22643 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22644 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22645 55 CONTINUE
22646 DO 60 I=1,MSPAR2
22647 PSOFT2(1,I) = 0.D0
22648 PSOFT2(2,I) = 0.D0
22649 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22650 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22651 60 CONTINUE
22652
22653 KSOFT = MAX(MSPAR1,MSPAR2)
22654 KHARD = MAX(MHPAR1,MHPAR2)
22655 KSPOM = MSPOM
22656 KSREG = MSREG
22657 KHPOM = MHPOM
22658
22659C debug output
22660 IF(IDEB(24).GE.10) THEN
22661 WRITE(LO,'(/1X,A,2I3,2I5)')
22662 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22663 & IVAL1,IVAL2,ITRY,NTRY
22664 IF(MSPAR1+MSPAR2.GT.0) THEN
22665 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22666 XTMP1 = 0.D0
22667 XTMP2 = 0.D0
22668 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22669 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22670 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22671 XTMP1 = XTMP1+XS1(I)
22672 XTMP2 = XTMP2+XS2(I)
22673 ELSE IF(I.LE.MSPAR1) THEN
22674 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22675 XTMP1 = XTMP1+XS1(I)
22676 ELSE IF(I.LE.MSPAR2) THEN
22677 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22678 XTMP2 = XTMP2+XS2(I)
22679 ENDIF
22680 105 CONTINUE
22681 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22682 ENDIF
22683 IF(MHPAR1.GT.0) THEN
22684 WRITE(LO,'(5X,A)')
22685 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22686 DO 107 K=1,MHPAR1
22687 I = LSIDX(K)
22688 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22689 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22690 & NINHD(I,1),NINHD(I,2)
22691 XTMP1 = XTMP1+XHD(I,1)
22692 XTMP2 = XTMP2+XHD(I,2)
22693 107 CONTINUE
22694 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22695 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22696 DO 108 K=1,MHPAR1
22697 I = LSIDX(K)
22698 I3 = 8*I-4
22699 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22700 & NOUTHD(I,1)
22701 108 CONTINUE
22702 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22703 DO 110 K=1,MHPAR2
22704 I = LSIDX(K)
22705 I3 = 8*I-4
22706 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22707 & NOUTHD(I,2)
22708 110 CONTINUE
22709 ENDIF
22710 ENDIF
22711 RETURN
22712
22713C event rejected, print debug information
22714 450 CONTINUE
22715 IFAIL(4) = IFAIL(4)+1
22716 IF(IDEB(24).GE.2) THEN
22717 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22718 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22719 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22720 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22721 IF(IDEB(24).GE.5) THEN
22722 CALL PHO_PREVNT(0)
22723 ELSE
22724 CALL PHO_PREVNT(-1)
22725 ENDIF
22726 ENDIF
22727
22728 END
22729
22730*$ CREATE PHO_HARX12.FOR
22731*COPY PHO_HARX12
22732CDECK ID>, PHO_HARX12
22733 SUBROUTINE PHO_HARX12
22734C**********************************************************************
22735C
22736C selection of x1 and x2 according to 1/x1*1/x2
22737C
22738C**********************************************************************
22739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22740 SAVE
22741
22742 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22743
22744C input/output channels
22745 INTEGER LI,LO
22746 COMMON /POINOU/ LI,LO
22747C data on most recent hard scattering
22748 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22749 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22750 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22751 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22752 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22753 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22754 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22755 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22756 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22757
2275810 CONTINUE
22759 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22760 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22761 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22762 X1 = EXP(Z1)
22763 X2 = EXP(Z2)
22764 AXX = AH/(X1*X2)
22765 W = SQRT(MAX(TINY,1.D0-AXX))
22766 W1 = AXX/(1.D0+W)
22767
22768 END
22769
22770*$ CREATE PHO_HARDX1.FOR
22771*COPY PHO_HARDX1
22772CDECK ID>, PHO_HARDX1
22773 SUBROUTINE PHO_HARDX1
22774C**********************************************************************
22775C
22776C selection of x1 according to 1/x1
22777C ( x2 = 1 )
22778C
22779C**********************************************************************
22780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22781 SAVE
22782
22783 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22784
22785C input/output channels
22786 INTEGER LI,LO
22787 COMMON /POINOU/ LI,LO
22788C data on most recent hard scattering
22789 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22790 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22791 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22792 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22793 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22794 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22795 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22796 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22797 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22798
22799 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22800 X2 = 1.D0
22801 X1 = EXP(Z1)
22802 AXX = AH/X1
22803 W = SQRT(MAX(TINY,1.D0-AXX))
22804 W1 = AXX/(1.D0+W)
22805
22806 END
22807
22808*$ CREATE PHO_HARKIN.FOR
22809*COPY PHO_HARKIN
22810CDECK ID>, PHO_HARKIN
22811 SUBROUTINE PHO_HARKIN(IREJ)
22812C***********************************************************************
22813C
22814C selection of kinematic variables
22815C (resolved and direct processes)
22816C
22817C***********************************************************************
22818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22819 SAVE
22820
22821 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22822
22823C input/output channels
22824 INTEGER LI,LO
22825 COMMON /POINOU/ LI,LO
22826C event debugging information
22827 INTEGER NMAXD
22828 PARAMETER (NMAXD=100)
22829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22833C data of c.m. system of Pomeron / Reggeon exchange
22834 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22835 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22836 & SIDP,CODP,SIFP,COFP
22837 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22838 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22839 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22840C data on most recent hard scattering
22841 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22842 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22843 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22844 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22845 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22846 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22847 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22848 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22849 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22850C internal cross check information on hard scattering limits
22851 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22852 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22853
22854 PARAMETER ( Max_pro_2 = 16 )
22855 DIMENSION RM(-1:Max_pro_2)
22856 DATA RM / 3.31D0, 0.0D0,
22857 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22858 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
22859 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
22860 & 1.0D0 /
22861
22862 IREJ = 0
22863 M = MSPR
22864
22865C------------- resolved processes -----------
22866 IF ( M.EQ.1 ) THEN
2286710 CALL PHO_HARX12
22868 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22869 U =-1.D0-V
22870 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22871 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22872 & 'PHO_HARKIN:weight error',M
22873 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22874 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22875 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
2287620 CALL PHO_HARX12
22877 WL = LOG(W1)
22878 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22879 U =-1.D0-V
22880 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22881 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22882 & 'PHO_HARKIN:weight error',M
22883 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22884 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22885 ELSEIF ( M.EQ.3 ) THEN
2288630 CALL PHO_HARX12
22887 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22888 U =-1.D0-V
22889 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22890 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22891 & 'PHO_HARKIN:weight error',M
22892 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22893 ELSEIF ( M.EQ.5 ) THEN
2289450 CALL PHO_HARX12
22895 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22896 U =-1.D0-V
22897 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22898 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22899 & 'PHO_HARKIN:weight error',M
22900 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22901 ELSEIF ( M.EQ.6 ) THEN
2290260 CALL PHO_HARX12
22903 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22904 U =-1.D0-V
22905 R = (4.D0/9.D0)*(U*U+V*V)*AXX
22906 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22907 & 'PHO_HARKIN:weight error',M
22908 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22909 ELSEIF ( M.EQ.7 ) THEN
2291070 CALL PHO_HARX12
22911 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22912 U =-1.D0-V
22913 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22914 & -(4.D0/27.D0)*V/U)
22915 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22916 & 'PHO_HARKIN:weight error',M
22917 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22918 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22919 ELSEIF ( M.EQ.8 ) THEN
2292080 CALL PHO_HARX12
22921 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22922 U =-1.D0-V
22923 R = (4.D0/9.D0)*(1.D0+U*U)
22924 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22925 & 'PHO_HARKIN:weight error',M
22926 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22927 ELSEIF ( M.EQ.-1 ) THEN
2292890 CALL PHO_HARX12
22929 WL = LOG(W1)
22930 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22931 U =-1.D0-V
22932 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22933 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22934 & 'PHO_HARKIN:weight error',M
22935 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22936C------------- direct / single-resolved processes -----------
22937 ELSEIF ( M.EQ.10 ) THEN
22938100 CALL PHO_HARDX1
22939 WL = LOG(AXX/(1.D0+W)**2)
22940 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22941 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22942 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22943 & 'PHO_HARKIN:weight error',M
22944 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22945 V =-1.D0-U
22946 X2 = X1
22947 X1 = 1.D0
22948 ELSEIF ( M.EQ.11) THEN
22949110 CALL PHO_HARDX1
22950 WL = LOG(W1)
22951 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22952 V =-1.D0-U
22953 R = (U*U+V*V)/V*WL*AXX
22954 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22955 & 'PHO_HARKIN:weight error',M
22956 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22957 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22958 X2 = X1
22959 X1 = 1.D0
22960 ELSEIF ( M.EQ.12 ) THEN
22961120 CALL PHO_HARDX1
22962 WL = LOG(AXX/(1.D0+W)**2)
22963 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22964 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22965 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22966 & 'PHO_HARKIN:weight error',M
22967 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22968 ELSEIF ( M.EQ.13) THEN
22969130 CALL PHO_HARDX1
22970 WL = LOG(W1)
22971 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22972 U =-1.D0-V
22973 R = (U*U+V*V)/U*WL*AXX
22974 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22975 & 'PHO_HARKIN:weight error',M
22976 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22977 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22978C------------- (double) direct process -----------
22979 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
22980 X1 = 1.D0
22981 X2 = 1.D0
22982 AXX= AH
22983 W = SQRT(MAX(TINY,1.D0-AXX))
22984 W1 = AXX/(1.D0+W)
22985 WL = LOG(W1)
22986 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22987 U =-1.D0-V
22988 R = -(U*U+V*V)/U
22989 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22990 & 'PHO_HARKIN:weight error',M
22991 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
22992 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22993C---------------------------------------------
22994 ELSE
22995 WRITE(LO,'(/1X,A,I3)')
22996 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
22997 CALL PHO_ABORT
22998 ENDIF
22999
23000 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23001 U = -1.D0-V
23002 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23003 PT = SQRT(U*V*X1*X2)*ECMP
23004 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23005 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23006
23007***************************************************************
23008 MM = M
23009 IF(M.EQ.-1) MM = 3
23010 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23011 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23012 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23013 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23014 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23015 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23016 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23017 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23018***************************************************************
23019
23020 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23021 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23022
23023 END
23024
23025*$ CREATE PHO_HARWGH.FOR
23026*COPY PHO_HARWGH
23027CDECK ID>, PHO_HARWGH
23028 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23029C***********************************************************************
23030C
23031C calculate product of PDFs and coupling constants
23032C according to selected MSPR (process type)
23033C
23034C input: /POCKIN/
23035C
23036C output: PDS resulting from PDFs alone
23037C FDISTR complete weight function
23038C PDA,PDB fields containing the PDFs
23039C
23040C***********************************************************************
23041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23042 SAVE
23043
23044 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23045
23046C input/output channels
23047 INTEGER LI,LO
23048 COMMON /POINOU/ LI,LO
23049C event debugging information
23050 INTEGER NMAXD
23051 PARAMETER (NMAXD=100)
23052 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23053 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23054 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23055 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23056C model switches and parameters
23057 CHARACTER*8 MDLNA
23058 INTEGER ISWMDL,IPAMDL
23059 DOUBLE PRECISION PARMDL
23060 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23061C data of c.m. system of Pomeron / Reggeon exchange
23062 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23063 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23064 & SIDP,CODP,SIFP,COFP
23065 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23066 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23067 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23068C currently activated parton density parametrizations
23069 CHARACTER*8 PDFNAM
23070 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23071 DOUBLE PRECISION PDFLAM,PDFQ2M
23072 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23073 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23074C hard scattering parameters used for most recent hard interaction
23075 INTEGER NFbeta,NF
23076 DOUBLE PRECISION ALQCD2,BQCD
23077 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23078C some hadron information, will be deleted in future versions
23079 INTEGER NFS
23080 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23081 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23082C scale parameters for parton model calculations
23083 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23084 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23085 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23086 & NQQAL,NQQALI,NQQALF,NQQPD
23087C data on most recent hard scattering
23088 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23089 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23090 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23091 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23092 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23093 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23094 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23095 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23096 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23097C hard cross sections and MC selection weights
23098 INTEGER Max_pro_2
23099 PARAMETER ( Max_pro_2 = 16 )
23100 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23101 & MH_acc_1,MH_acc_2
23102 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23103 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23104 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23105 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23106 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23107 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23108C some constants
23109 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23110 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23111 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23112
23113 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23114 DIMENSION PDA(-6:6),PDB(-6:6)
23115
23116 FDISTR = 0.D0
23117C set hard scale QQ for alpha and partondistr.
23118 IF ( NQQAL.EQ.1 ) THEN
23119 QQAL = AQQAL*PT*PT
23120 ELSEIF ( NQQAL.EQ.2 ) THEN
23121 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23122 ELSEIF ( NQQAL.EQ.3 ) THEN
23123 QQAL = AQQAL*X1*X2*ECMP*ECMP
23124 ELSEIF ( NQQAL.EQ.4 ) THEN
23125 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23126 ENDIF
23127 IF ( NQQPD.EQ.1 ) THEN
23128 QQPD = AQQPD*PT*PT
23129 ELSEIF ( NQQPD.EQ.2 ) THEN
23130 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23131 ELSEIF ( NQQPD.EQ.3 ) THEN
23132 QQPD = AQQPD*X1*X2*ECMP*ECMP
23133 ELSEIF ( NQQPD.EQ.4 ) THEN
23134 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23135 ENDIF
23136C coupling constants, PDFs
23137 IF(MSPR.LT.9) THEN
23138 ALPHA1 = PHO_ALPHAS(QQAL,3)
23139 ALPHA2 = ALPHA1
23140 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23141 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23142 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23143 PDS = PDA(0)*PDB(0)
23144 ELSE
23145 S2 = 0.D0
23146 S3 = 0.D0
23147 S4 = 0.D0
23148 S5 = 0.D0
23149 DO 10 I=1,NF
23150 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23151 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23152 S4 = S4+PDA(I)+PDA(-I)
23153 S5 = S5+PDB(I)+PDB(-I)
23154 10 CONTINUE
23155 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23156 PDS = S2
23157 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23158 PDS = PDA(0)*S5+PDB(0)*S4
23159 ELSE IF(MSPR.EQ.7) THEN
23160 PDS = S3
23161 ELSE IF(MSPR.EQ.8) THEN
23162 PDS = S4*S5-(S2+S3)
23163 ENDIF
23164 ENDIF
23165 ELSE IF(MSPR.LT.12) THEN
23166 ALPHA2 = PHO_ALPHAS(QQAL,2)
23167 IF(IDPDG1.EQ.22) THEN
23168 ALPHA1 = pho_alphae(QQAL)
23169 ELSE IF(IDPDG1.EQ.990) THEN
23170 ALPHA1 = PARMDL(74)
23171 ENDIF
23172 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23173 S4 = 0.D0
23174 S6 = 0.D0
23175 DO 15 I=1,NF
23176 S4 = S4+PDB(I)+PDB(-I)
23177C charge counting
23178* IF(MOD(I,2).EQ.0) THEN
23179* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23180* ELSE
23181* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23182* ENDIF
23183 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23184 15 CONTINUE
23185 IF(MSPR.EQ.10) THEN
23186 IF(IDPDG1.EQ.990) THEN
23187 PDS = S4
23188 ELSE
23189 PDS = S6
23190 ENDIF
23191 ELSE
23192 PDS = PDB(0)
23193 ENDIF
23194 ELSE IF(MSPR.LT.14) THEN
23195 ALPHA1 = PHO_ALPHAS(QQAL,1)
23196 IF(IDPDG2.EQ.22) THEN
23197 ALPHA2 = pho_alphae(QQAL)
23198 ELSE IF(IDPDG2.EQ.990) THEN
23199 ALPHA2 = PARMDL(74)
23200 ENDIF
23201 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23202 S4 = 0.D0
23203 S6 = 0.D0
23204 DO 20 I=1,NF
23205 S4 = S4+PDA(I)+PDA(-I)
23206C charge counting
23207* IF(MOD(I,2).EQ.0) THEN
23208* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23209* ELSE
23210* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23211* ENDIF
23212 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23213 20 CONTINUE
23214 IF(MSPR.EQ.12) THEN
23215 IF(IDPDG2.EQ.990) THEN
23216 PDS = S4
23217 ELSE
23218 PDS = S6
23219 ENDIF
23220 ELSE
23221 PDS = PDA(0)
23222 ENDIF
23223 ELSE IF(MSPR.EQ.14) THEN
23224 SSR = X1*X2*ECMP*ECMP
23225 IF(IDPDG1.EQ.22) THEN
23226 ALPHA1 = pho_alphae(SSR)
23227 ELSE IF(IDPDG1.EQ.990) THEN
23228 ALPHA1 = PARMDL(74)
23229 ENDIF
23230 IF(IDPDG2.EQ.22) THEN
23231 ALPHA2 = pho_alphae(SSR)
23232 ELSE IF(IDPDG2.EQ.990) THEN
23233 ALPHA2 = PARMDL(74)
23234 ENDIF
23235 PDS = 1.D0
23236 ELSE
23237 WRITE(LO,'(/1X,A,I4)')
23238 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23239 CALL PHO_ABORT
23240 ENDIF
23241
23242C complete weight
23243 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23244
23245C debug output
23246 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23247 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23248 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23249
23250 END
23251
23252*$ CREATE PHO_HARSCA.FOR
23253*COPY PHO_HARSCA
23254CDECK ID>, PHO_HARSCA
23255 SUBROUTINE PHO_HARSCA(IMODE,IP)
23256C***********************************************************************
23257C
23258C PHO_HARSCA determines the type of hard subprocess, the partons
23259C taking part in this subprocess and the kinematic variables
23260C
23261C input: IMODE 1 direct processes
23262C 2 resolved processes
23263C -1 initialization
23264C -2 output of statistics
23265C IP 1-4 particle combination (hadron/photon)
23266C
23267C***********************************************************************
23268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23269 SAVE
23270
23271 PARAMETER( EPS = 1.D-10,
23272 & DEPS = 1.D-30 )
23273
23274C input/output channels
23275 INTEGER LI,LO
23276 COMMON /POINOU/ LI,LO
23277C event debugging information
23278 INTEGER NMAXD
23279 PARAMETER (NMAXD=100)
23280 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23281 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23282 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23283 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23284C model switches and parameters
23285 CHARACTER*8 MDLNA
23286 INTEGER ISWMDL,IPAMDL
23287 DOUBLE PRECISION PARMDL
23288 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23289C internal rejection counters
23290 INTEGER NMXJ
23291 PARAMETER (NMXJ=60)
23292 CHARACTER*10 REJTIT
23293 INTEGER IFAIL
23294 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23295C hard scattering parameters used for most recent hard interaction
23296 INTEGER NFbeta,NF
23297 DOUBLE PRECISION ALQCD2,BQCD
23298 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23299C data of c.m. system of Pomeron / Reggeon exchange
23300 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23301 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23302 & SIDP,CODP,SIFP,COFP
23303 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23304 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23305 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23306C names of hard scattering processes
23307 INTEGER Max_pro_1
23308 PARAMETER ( Max_pro_1 = 16 )
23309 CHARACTER*18 PROC
23310 COMMON /POHPRO/ PROC(0:Max_pro_1)
23311C data on most recent hard scattering
23312 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23313 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23314 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23315 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23316 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23317 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23318 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23319 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23320 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23321C hard scattering data
23322 INTEGER MSCAHD
23323 PARAMETER ( MSCAHD = 50 )
23324 INTEGER LSCAHD,LSC1HD,LSIDX,
23325 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23326 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23327 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23328 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23329 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23330 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23331 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23332 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23333 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23334C hard cross sections and MC selection weights
23335 INTEGER Max_pro_2
23336 PARAMETER ( Max_pro_2 = 16 )
23337 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23338 & MH_acc_1,MH_acc_2
23339 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23340 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23341 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23342 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23343 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23344 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23345C cross sections
23346 INTEGER IPFIL,IFAFIL,IFBFIL
23347 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23348 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23349 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23350 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23351 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23352 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23353 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23354 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23355 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23356 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23357 & IPFIL,IFAFIL,IFBFIL
23358C some constants
23359 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23360 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23361 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23362
23363 111 CONTINUE
23364
23365C resolved processes
23366 IF(IMODE.EQ.2) THEN
23367
23368 MH_pro_on(0,IP) = 0
23369 HWgx(9) = 0.D0
23370 DO 15 M=-1,8
23371 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23372 15 CONTINUE
23373 IF(HWgx(9).LT.DEPS) THEN
23374 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23375 & 'no resolved process possible for IP',IP,HWgx(9)
23376 CALL PHO_ABORT
23377 ENDIF
23378C
23379C ----------------------------------------------I
23380C begin of iteration loop (resolved processes) I
23381C I
23382 IREJSC = 0
23383 10 CONTINUE
23384 IREJSC = IREJSC+1
23385 IF(IREJSC.GT.1000) THEN
23386 WRITE(LO,'(/1X,A,I10)')
23387 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23388 CALL PHO_ABORT
23389 ENDIF
23390
23391C find subprocess
23392 B = DT_RNDM(X1)*HWgx(9)
23393 MSPR =-2
23394 SUM = 0.D0
23395 20 MSPR = MSPR+1
23396 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23397 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23398
23399 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23400 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23401
23402C find kin. variables X1,X2 and V
23403 CALL PHO_HARKIN(IREJ)
23404 IF(IREJ.NE.0) THEN
23405 IFAIL(29) = IFAIL(29)+1
23406 GOTO 10
23407 ENDIF
23408C calculate remaining distribution
23409 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23410C actualize counter for cross-section calculation
23411 if(F.LE.1.D-15) then
23412 F = 0.D0
23413 goto 10
23414 endif
23415* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23416* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23417 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23418C check F against FMAX
23419 WEIGHT = F/(HWgx(MSPR)+DEPS)
23420 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23421C-------------------------------------------------------------------
23422 IF(WEIGHT.GT.1.D0) THEN
23423 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23424 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23425 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23426 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23427 & ECMP,PTWANT,AS,AH,PT
23428 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23429 & ETAC,ETAD,X1,X2,V
23430 CALL PHO_PREVNT(-1)
23431 ENDIF
23432C-------------------------------------------------------------------
23433C I
23434C end of iteration loop (resolved processes) I
23435C --------------------------------------------I
23436C
23437C*********************************************************************
23438C
23439C direct processes
23440
23441 ELSE IF(IMODE.EQ.1) THEN
23442
23443C single-resolved processes kinematically forbidden
23444 if(Z1DIF.lt.0.D0) then
23445 HWgx(10) = 0.D0
23446 HWgx(11) = 0.D0
23447 HWgx(12) = 0.D0
23448 HWgx(13) = 0.D0
23449 endif
23450
23451 HWgx(15) = 0.D0
23452 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23453 DO M= 10,14
23454 IF(MH_pro_on(M,IP).EQ.1) then
23455 if((M.eq.10).or.(M.eq.11)) then
23456 fac = FSUH(1)*FSUP(2)
23457 else if((M.eq.12).or.(M.eq.13)) then
23458 fac = FSUP(1)*FSUH(2)
23459 else
23460 fac = FSUH(1)*FSUH(2)
23461 endif
23462 HWgx(15) = HWgx(15)+HWgx(M)*fac
23463 endif
23464 ENDDO
23465 else
23466 DO M= 10,14
23467 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23468 ENDDO
23469 endif
23470 IF(HWgx(15).LT.DEPS) THEN
23471 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23472 & 'no direct/single-resolved process possible (IP)',IP
23473 CALL PHO_ABORT
23474 ENDIF
23475C
23476C ----------------------------------------------I
23477C begin of iteration loop (direct processes) I
23478C I
23479 IREJSC = 0
23480 100 CONTINUE
23481 IREJSC = IREJSC+1
23482 IF(IREJSC.GT.1000) THEN
23483 WRITE(LO,'(/1X,A,I10)')
23484 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23485 CALL PHO_ABORT
23486 ENDIF
23487
23488C find subprocess
23489 B = DT_RNDM(X1)*HWgx(15)
23490 MSPR = 9
23491 SUM = 0.D0
23492 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23493 150 continue
23494 MSPR = MSPR+1
23495 IF(MH_pro_on(MSPR,IP).EQ.1) then
23496 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23497 fac = FSUH(1)*FSUP(2)
23498 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23499 fac = FSUP(1)*FSUH(2)
23500 else
23501 fac = FSUH(1)*FSUH(2)
23502 endif
23503 SUM = SUM+HWgx(MSPR)*fac
23504 endif
23505 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23506 else
23507 200 continue
23508 MSPR = MSPR+1
23509 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23510 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23511 endif
23512
23513 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23514 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23515
23516C find kin. variables X1,X2 and V
23517 CALL PHO_HARKIN(IREJ)
23518 IF(IREJ.NE.0) THEN
23519 IFAIL(28) = IFAIL(28)+1
23520 GOTO 100
23521 ENDIF
23522
23523C calculate remaining distribution
23524 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23525
23526C counter for cross-section calculation
23527 if(F.LE.1.D-15) then
23528 F=0.D0
23529 goto 100
23530 endif
23531* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23532* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23533 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23534C check F against FMAX
23535 WEIGHT = F/(HWgx(MSPR)+DEPS)
23536 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23537C-------------------------------------------------------------------
23538 IF(WEIGHT.GT.1.D0) THEN
23539 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23540 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23541 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23542 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23543 & ECMP,PTWANT,AS,AH,PT
23544 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23545 & ETAC,ETAD,X1,X2,V
23546 CALL PHO_PREVNT(-1)
23547 ENDIF
23548C-------------------------------------------------------------------
23549C I
23550C end of iteration loop (direct processes) I
23551C --------------------------------------------I
23552
23553 ELSE IF(IMODE.EQ.-1) THEN
23554
23555C initialize cross section calculations
23556
23557 DO 40 M=-1,Max_pro_2
23558* DO 30 I=5,6
23559* XSECT(I,M) = 0.D0
23560*30 CONTINUE
23561C reset counters
23562 DO 35 J=1,4
23563 MH_tried(M,J) = 0
23564 MH_acc_1(M,J) = 0
23565 MH_acc_2(M,J) = 0
23566 35 CONTINUE
23567 40 CONTINUE
23568 IF(IDEB(78).GE.0) THEN
23569 WRITE(LO,'(/1X,A,/1X,A)')
23570 & 'PHO_HARSCA: activated hard processes',
23571 & '------------------------------------'
23572 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23573 DO 42 M=1,Max_pro_2
23574 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23575 & (MH_pro_on(M,J),J=1,4)
23576 42 CONTINUE
23577 ENDIF
23578 RETURN
23579
23580 ELSE IF(IMODE.EQ.-2) THEN
23581
23582C calculation of process statistics
23583
23584 do K=1,4
23585
23586 MH_tried(0,K) = 0
23587 MH_acc_1(0,K) = 0
23588 MH_acc_2(0,K) = 0
23589 MH_tried(9,K) = 0
23590 MH_acc_1(9,K) = 0
23591 MH_acc_2(9,K) = 0
23592 MH_tried(15,K) = 0
23593 MH_acc_1(15,K) = 0
23594 MH_acc_2(15,K) = 0
23595
23596 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23597 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23598 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23599
23600 do M=1,8
23601 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23602 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23603 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23604 enddo
23605 do M=10,14
23606 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23607 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23608 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23609 enddo
23610 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23611 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23612 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23613 enddo
23614
23615 IF(IDEB(78).GE.1) THEN
23616 WRITE(LO,'(/1X,A,/1X,A)')
23617 & 'PHO_HARSCA: internal rejection statistics',
23618 & '-----------------------------------------'
23619 do K=1,4
23620 IF(MH_tried(0,K).GT.0) THEN
23621 WRITE(LO,'(5X,A,I3)')
23622 & 'process (sampled/accepted) for IP:',K
23623 do M=0,Max_pro_2
23624 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23625 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23626 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23627 enddo
23628 ENDIF
23629 enddo
23630 ENDIF
23631 RETURN
23632
23633 ELSE
23634 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23635 & 'unsupported mode',IMODE
23636 CALL PHO_ABORT
23637 ENDIF
23638
23639C the event is accepted now
23640C actualize counter for accepted events
23641 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23642 IF(MSPR.EQ.-1) MSPR = 3
23643C
23644C find flavor of initial partons
23645C
23646 SUM = 0.D0
23647 SCHECK = DT_RNDM(SUM)*PDS-EPS
23648 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23649 IA = 0
23650 IB = 0
23651 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23652 DO 610 IA=-NF,NF
23653 IF ( IA.EQ.0 ) GOTO 610
23654 SUM = SUM+PDF1(IA)*PDF2(-IA)
23655 IF ( SUM.GE.SCHECK ) GOTO 620
23656 610 CONTINUE
23657 620 IB =-IA
23658 ELSEIF ( MSPR.EQ.3 ) THEN
23659 IB = 0
23660 DO 630 IA=-NF,NF
23661 IF ( IA.EQ.0 ) GOTO 630
23662 SUM = SUM+PDF1(0)*PDF2(IA)
23663 IF ( SUM.GE.SCHECK ) GOTO 640
23664 SUM = SUM+PDF1(IA)*PDF2(0)
23665 IF ( SUM.GE.SCHECK ) GOTO 650
23666 630 CONTINUE
23667 640 IB = IA
23668 IA = 0
23669 650 CONTINUE
23670 ELSEIF ( MSPR.EQ.7 ) THEN
23671 DO 660 IA=-NF,NF
23672 IF ( IA.EQ.0 ) GOTO 660
23673 SUM = SUM+PDF1(IA)*PDF2(IA)
23674 IF ( SUM.GE.SCHECK ) GOTO 670
23675 660 CONTINUE
23676 670 IB = IA
23677 ELSEIF ( MSPR.EQ.8 ) THEN
23678 DO 690 IA=-NF,NF
23679 IF ( IA.EQ.0 ) GOTO 690
23680 DO 680 IB=-NF,NF
23681 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23682 SUM = SUM+PDF1(IA)*PDF2(IB)
23683 IF ( SUM.GE.SCHECK ) GOTO 700
23684 680 CONTINUE
23685 690 CONTINUE
23686 700 CONTINUE
23687 ELSEIF ( MSPR.EQ.10 ) THEN
23688 IA = 0
23689 DO 710 IB=-NF,NF
23690 IF ( IB.NE.0 ) THEN
23691 IF(IDPDG1.EQ.22) THEN
23692* IF(MOD(ABS(IB),2).EQ.0) THEN
23693* SUM = SUM+PDF2(IB)*4.D0/9.D0
23694* ELSE
23695* SUM = SUM+PDF2(IB)*1.D0/9.D0
23696* ENDIF
23697 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23698 ELSE
23699 SUM = SUM+PDF2(IB)
23700 ENDIF
23701 IF ( SUM.GE.SCHECK ) GOTO 720
23702 ENDIF
23703 710 CONTINUE
23704 720 CONTINUE
23705 ELSEIF ( MSPR.EQ.12 ) THEN
23706 IB = 0
23707 DO 810 IA=-NF,NF
23708 IF ( IA.NE.0 ) THEN
23709 IF(IDPDG2.EQ.22) THEN
23710* IF(MOD(ABS(IA),2).EQ.0) THEN
23711* SUM = SUM+PDF1(IA)*4.D0/9.D0
23712* ELSE
23713* SUM = SUM+PDF1(IA)*1.D0/9.D0
23714* ENDIF
23715 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23716 ELSE
23717 SUM = SUM+PDF1(IA)
23718 ENDIF
23719 IF ( SUM.GE.SCHECK ) GOTO 820
23720 ENDIF
23721 810 CONTINUE
23722 820 CONTINUE
23723 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23724 IA = 0
23725 IB = 0
23726 ENDIF
23727C final check
23728 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
ecf67adb 23729 WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23730 WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
9aaba0d6 23731 GOTO 111
23732 ENDIF
23733C
23734C find flavour of final partons
23735C
23736 IC = IA
23737 ID = IB
23738 IF ( MSPR.EQ.2 ) THEN
23739 IC = 0
23740 ID = 0
23741 ELSEIF ( MSPR.EQ.4 ) THEN
23742 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23743 IF ( IC.GT.NF ) IC = NF-IC
23744 ID =-IC
23745 ELSEIF ( MSPR.EQ.6 ) THEN
23746 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23747 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23748 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23749 ID =-IC
23750 ELSEIF ( MSPR.EQ.11) THEN
23751 SUM = 0.D0
23752 DO 730 IC=-NF,NF
23753 IF ( IC.NE.0 ) THEN
23754 IF(IDPDG1.EQ.22) THEN
23755* IF(MOD(ABS(IC),2).EQ.0) THEN
23756* SUM = SUM + 4.D0
23757* ELSE
23758* SUM = SUM + 1.D0
23759* ENDIF
23760 SUM = SUM + Q_ch2(IC)
23761 ELSE
23762 SUM = SUM + 1.D0
23763 ENDIF
23764 ENDIF
23765 730 CONTINUE
23766 SCHECK = DT_RNDM(SUM)*SUM-EPS
23767 SUM = 0.D0
23768 DO 740 IC=-NF,NF
23769 IF ( IC.NE.0 ) THEN
23770 IF(IDPDG1.EQ.22) THEN
23771* IF(MOD(ABS(IC),2).EQ.0) THEN
23772* SUM = SUM + 4.D0
23773* ELSE
23774* SUM = SUM + 1.D0
23775* ENDIF
23776 SUM = SUM + Q_ch2(IC)
23777 ELSE
23778 SUM = SUM + 1.D0
23779 ENDIF
23780 IF ( SUM.GE.SCHECK ) GOTO 750
23781 ENDIF
23782 740 CONTINUE
23783 750 CONTINUE
23784 ID = -IC
23785 ELSEIF ( MSPR.EQ.12) THEN
23786 IC = 0
23787 ID = IA
23788 ELSEIF ( MSPR.EQ.13) THEN
23789 SUM = 0.D0
23790 DO 830 IC=-NF,NF
23791 IF ( IC.NE.0 ) THEN
23792 IF(IDPDG2.EQ.22) THEN
23793* IF(MOD(ABS(IC),2).EQ.0) THEN
23794* SUM = SUM + 4.D0
23795* ELSE
23796* SUM = SUM + 1.D0
23797* ENDIF
23798 SUM = SUM + Q_ch2(IC)
23799 ELSE
23800 SUM = SUM + 1.D0
23801 ENDIF
23802 ENDIF
23803 830 CONTINUE
23804 SCHECK = DT_RNDM(SUM)*SUM-EPS
23805 SUM = 0.D0
23806 DO 840 IC=-NF,NF
23807 IF ( IC.NE.0 ) THEN
23808 IF(IDPDG2.EQ.22) THEN
23809* IF(MOD(ABS(IC),2).EQ.0) THEN
23810* SUM = SUM + 4.D0
23811* ELSE
23812* SUM = SUM + 1.D0
23813* ENDIF
23814 SUM = SUM + Q_ch2(IC)
23815 ELSE
23816 SUM = SUM + 1.D0
23817 ENDIF
23818 IF ( SUM.GE.SCHECK ) GOTO 850
23819 ENDIF
23820 840 CONTINUE
23821 850 CONTINUE
23822 ID = -IC
23823 ELSEIF ( MSPR.EQ.14) THEN
23824 SUM = 0.D0
23825 DO 930 IC=1,NF
23826 FAC1 = 1.D0
23827 FAC2 = 1.D0
23828 IF(MOD(ABS(IC),2).EQ.0) THEN
23829 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23830 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23831 ENDIF
23832 SUM = SUM + FAC1*FAC2
23833 930 CONTINUE
23834 IF(IPAMDL(64).NE.0) THEN
23835 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23836 ENDIF
23837 SCHECK = DT_RNDM(SUM)*SUM-EPS
23838 SUM = 0.D0
23839 DO 940 IC=1,NF
23840 FAC1 = 1.D0
23841 FAC2 = 1.D0
23842 IF(MOD(ABS(IC),2).EQ.0) THEN
23843 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23844 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23845 ENDIF
23846 SUM = SUM + FAC1*FAC2
23847 IF ( SUM.GE.SCHECK ) GOTO 950
23848 940 CONTINUE
23849 IC = 15
23850 950 CONTINUE
23851 ID = -IC
23852 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23853 ENDIF
23854 if(IC.eq.0) then
23855 XM3 = 0.D0
23856 else
23857 XM3 = PHO_PMASS(IC,3)
23858 endif
23859 if(ID.eq.0) then
23860 XM4 = 0.D0
23861 else
23862 XM4 = PHO_PMASS(ID,3)
23863 endif
23864 IF(ABS(IC).EQ.15) GOTO 955
23865
23866C valence quarks involved?
23867 IV1 = 0
23868 IF(IA.NE.0) THEN
23869 IF(IDPDG1.EQ.22) THEN
23870 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23871 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23872 ELSE
23873 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23874 ENDIF
23875 ENDIF
23876 IV2 = 0
23877 IF(IB.NE.0) THEN
23878 IF(IDPDG2.EQ.22) THEN
23879 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23880 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23881 ELSE
23882 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23883 ENDIF
23884 ENDIF
23885C
23886C fill event record
23887C
23888 955 CONTINUE
23889 CALL PHO_SFECFE(SINPHI,COSPHI)
23890 ECM2 = ECMP/2.D0
23891C incoming partons
23892 PHI1(1) = 0.D0
23893 PHI1(2) = 0.D0
23894 PHI1(3) = ECM2*X1
23895 PHI1(4) = PHI1(3)
23896 PHI1(5) = 0.D0
23897 PHI2(1) = 0.D0
23898 PHI2(2) = 0.D0
23899 PHI2(3) = -ECM2*X2
23900 PHI2(4) = -PHI2(3)
23901 PHI2(5) = 0.D0
23902C outgoing partons
23903 PHO1(1) = PT*COSPHI
23904 PHO1(2) = PT*SINPHI
23905 PHO1(3) = -ECM2*(U*X1-V*X2)
23906 PHO1(4) = -ECM2*(U*X1+V*X2)
23907 PHO1(5) = XM3
23908 PHO2(1) = -PHO1(1)
23909 PHO2(2) = -PHO1(2)
23910 PHO2(3) = -ECM2*(V*X1-U*X2)
23911 PHO2(4) = -ECM2*(V*X1+U*X2)
23912 PHO2(5) = XM4
23913
23914C convert to mass shell
23915 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23916 IF(IREJ.NE.0) THEN
23917 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23918 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23919 & PT,XM3,XM4
23920 GOTO 111
23921 ENDIF
23922 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23923
23924C debug output
23925 IF(IDEB(78).GE.20) THEN
23926 SHAT = X1*X2*ECMP*ECMP
23927 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23928 & MSPR,IA,IB,IC,ID
23929 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23930 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23931 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23932 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23933 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23934 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23935 ENDIF
23936
23937 END
23938
23939*$ CREATE PHO_HARFAC.FOR
23940*COPY PHO_HARFAC
23941CDECK ID>, PHO_HARFAC
23942 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23943C*********************************************************************
23944C
23945C initialization: find scaling factors and maxima of remaining
23946C weights
23947C
23948C input: PTCUT transverse momentum cutoff
23949C ECMI cms energy
23950C
23951C output: Hfac(-1:Max_pro_2) field for sampling hard processes
23952C
23953C*********************************************************************
23954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23955 SAVE
23956
23957 PARAMETER ( MXABWT = 96 )
23958
23959C input/output channels
23960 INTEGER LI,LO
23961 COMMON /POINOU/ LI,LO
23962C data of c.m. system of Pomeron / Reggeon exchange
23963 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23964 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23965 & SIDP,CODP,SIFP,COFP
23966 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23967 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23968 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23969C some constants
23970 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23971 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23972 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23973C hard scattering parameters used for most recent hard interaction
23974 INTEGER NFbeta,NF
23975 DOUBLE PRECISION ALQCD2,BQCD
23976 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23977C integration precision for hard cross sections (obsolete)
23978 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23979 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23980C data on most recent hard scattering
23981 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23982 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23983 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23984 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23985 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23986 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23987 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23988 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23989 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23990C hard cross sections and MC selection weights
23991 INTEGER Max_pro_2
23992 PARAMETER ( Max_pro_2 = 16 )
23993 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23994 & MH_acc_1,MH_acc_2
23995 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23996 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23997 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23998 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23999 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24000 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24001
24002 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24003 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24004 & F124(-1:Max_pro_2)
24005 DATA F124 / 1.D0,0.D0,
24006 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24007 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24008
24009 SS = ECMI*ECMI
24010 AH = (2.D0*PTCUT/ECMI)**2
24011 ALN = LOG(AH)
24012 HLN = LOG(0.5D0)
24013 NPOINT = NGAUIN
24014 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24015 DO 10 M=-1,Max_pro_2
24016 S1(M) = 0.D0
2401710 CONTINUE
24018
24019C resolved processes
24020 DO 80 I1=1,NPOINT
24021 Z1 = ABSZ(I1)
24022 X1 = EXP(ALN*Z1)
24023 DO 20 M=-1,9
24024 S2(M) = 0.D0
2402520 CONTINUE
24026
24027 DO 60 I2=1,NPOINT
24028 Z2 = (1.D0-Z1)*ABSZ(I2)
24029 X2 = EXP(ALN*Z2)
24030 FAXX = AH/(X1*X2)
24031 W = SQRT(1.D0-FAXX)
24032 W1 = FAXX/(1.+W)
24033 WLOG = LOG(W1)
24034 FWW = FAXX*WLOG/W
24035 DO 30 M=-1,9
24036 S(M) = 0.D0
2403730 CONTINUE
24038
24039 DO 40 I=1,NPOINT
24040 Z = ABSZ(I)
24041 VA =-0.5D0*W1/(W1+Z*W)
24042 UA =-1.D0-VA
24043 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24044 UB =-1.D0-VB
24045 VC =-EXP(HLN+Z*WLOG)
24046 UC =-1.D0-VC
24047 VE =-0.5D0*(1.D0+W)+Z*W
24048 UE =-1.D0-VE
24049 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24050 & WEIG(I)
24051 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24052 & WEIG(I)
24053 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24054 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24055 & (8./27.)*UA*UA*VA)*WEIG(I)
24056 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24057 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24058 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24059 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24060 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
2406140 CONTINUE
24062 S(4) = S(2)*(9./32.)
24063 DO 50 M=-1,8
24064 S2(M) = S2(M)+S(M)*WEIG(I2)*W
2406550 CONTINUE
2406660 CONTINUE
24067 DO 70 M=-1,8
24068 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
2406970 CONTINUE
2407080 CONTINUE
24071 S1(4) = S1(4)*NF
24072 S1(6) = S1(6)*MAX(0,NF-1)
24073C
24074C direct processes
24075 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24076 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24077 DO 180 I1=1,NPOINT
24078 Z2 = ABSZ(I1)
24079 X2 = EXP(ALN*Z2)
24080 FAXX = AH/X2
24081 W = SQRT(1.D0-FAXX)
24082 W1 = FAXX/(1.D0+W)
24083 WLOG = LOG(W1)
24084 WL = LOG(FAXX/(1.D0+W)**2)
24085 FWW1 = FAXX*WL/ALN
24086 FWW2 = FAXX*WLOG/ALN
24087 DO 130 M=10,12
24088 S(M) = 0.D0
24089 130 CONTINUE
24090C
24091 DO 140 I=1,NPOINT
24092 Z = ABSZ(I)
24093 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24094 VA =-1.D0-UA
24095 VB =-EXP(HLN+Z*WLOG)
24096 UB =-1.D0-VB
24097 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24098 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24099 140 CONTINUE
24100 DO 170 M=10,11
24101 S1(M) = S1(M)+S(M)*WEIG(I1)
24102 170 CONTINUE
24103 180 CONTINUE
24104 S1(12) = S1(10)
24105 S1(13) = S1(11)
24106C quark charges fractions
24107 IF(IDPDG1.EQ.22) THEN
24108 CHRNF = 0.D0
24109 DO 100 I=1,NF
24110 CHRNF = CHRNF + Q_ch2(I)
24111 100 CONTINUE
24112 S1(11) = S1(11)*CHRNF
24113 ELSE IF(IDPDG1.EQ.990) THEN
24114 S1(11) = S1(11)*NF
24115 ELSE
24116 S1(11) = 0.D0
24117 ENDIF
24118 IF(IDPDG2.EQ.22) THEN
24119 CHRNF = 0.D0
24120 DO 200 I=1,NF
24121 CHRNF = CHRNF + Q_ch2(I)
24122 200 CONTINUE
24123 S1(13) = S1(13)*CHRNF
24124 ELSE IF(IDPDG2.EQ.990) THEN
24125 S1(13) = S1(13)*NF
24126 ELSE
24127 S1(13) = 0.D0
24128 ENDIF
24129 ENDIF
24130C
24131C global factors
24132 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24133 DO 90 M=-1,Max_pro_2
24134 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
2413590 CONTINUE
24136C
24137C double direct process
24138 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24139 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24140 FAC = 0.D0
24141 DO 300 I=1,NF
24142 IF(IDPDG1.EQ.22) THEN
24143 F1 = Q_ch2(I)
24144 ELSE
24145 F1 = 1.D0
24146 ENDIF
24147 IF(IDPDG2.EQ.22) THEN
24148 F2 = Q_ch2(I)
24149 ELSE
24150 F2 = 1.D0
24151 ENDIF
24152 FAC = FAC+F1*F2*3.D0
24153 300 CONTINUE
24154 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24155 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24156 & *GEV2MB*FAC
24157 ENDIF
24158 END
24159
24160*$ CREATE PHO_HARWGX.FOR
24161*COPY PHO_HARWGX
24162CDECK ID>, PHO_HARWGX
24163 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24164C**********************************************************************
24165C
24166C find maximum of remaining weight for MC sampling
24167C
24168C input: PTCUT transverse momentum cutoff
24169C ECM cms energy
24170C
24171C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24172C
24173C**********************************************************************
24174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24175 SAVE
24176
24177 PARAMETER ( NKM = 10 )
24178 PARAMETER ( TINY = 1.D-20 )
24179
24180C input/output channels
24181 INTEGER LI,LO
24182 COMMON /POINOU/ LI,LO
24183C event debugging information
24184 INTEGER NMAXD
24185 PARAMETER (NMAXD=100)
24186 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24187 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24188 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24189 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24190C data on most recent hard scattering
24191 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24192 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24193 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24194 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24195 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24196 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24197 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24198 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24199 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24200C hard cross sections and MC selection weights
24201 INTEGER Max_pro_2
24202 PARAMETER ( Max_pro_2 = 16 )
24203 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24204 & MH_acc_1,MH_acc_2
24205 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24206 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24207 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24208 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24209 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24210 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24211
24212 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24213 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24214 DIMENSION IFTAB(-1:Max_pro_2)
24215 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24216
24217C initial settings
24218 AH = (2.D0*PTCUT/ECM)**2
24219 ALNH = LOG(AH)
24220 FF(0) = 0.D0
24221 DO 22 I=1,NKM
24222 FF(I) = 0.D0
24223 XM1(I) = 0.D0
24224 XM2(I) = 0.D0
24225 PTM(I) = 0.D0
24226 ZMX(1,I) = 0.D0
24227 ZMX(2,I) = 0.D0
24228 ZMX(3,I) = 0.D0
24229 DMX(1,I) = 0.D0
24230 DMX(2,I) = 0.D0
24231 DMX(3,I) = 0.D0
24232 IMX(I) = 0
24233 IPO(I) = 0
24234 22 CONTINUE
24235
24236 NKML = 10
24237 DO 40 NKON=1,NKML
24238
24239 DO 50 IST=1,3
24240C start configuration
24241 IF(IST.EQ.1) THEN
24242 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24243 Z(2) = 0.5
24244 Z(3) = 0.1
24245 D(1) =-0.5
24246 D(2) = 0.5
24247 D(3) = 0.5
24248 ELSE IF(IST.EQ.2) THEN
24249 Z(1) = 0.999D0
24250 Z(2) = 0.5
24251 Z(3) = 0.0
24252 D(1) =-0.5
24253 D(2) = 0.5
24254 D(3) = 0.5
24255 ELSE IF(IST.EQ.3) THEN
24256 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24257 Z(2) = 0.1
24258 Z(3) = 0.1
24259 D(1) =-0.5
24260 D(2) = 0.5
24261 D(3) = 0.5
24262 ELSE IF(IST.EQ.4) THEN
24263 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24264 Z(2) = 0.9
24265 Z(3) = 0.1
24266 D(1) =-0.5
24267 D(2) = 0.5
24268 D(3) = 0.5
24269 ENDIF
24270 IT = 0
24271 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24272C process possible?
24273 IF(F2.LE.0.D0) GOTO 35
24274
24275 10 CONTINUE
24276 IT = IT+1
24277 FOLD = F2
24278 DO 30 I=1,3
24279 D(I) = D(I)/5.D0
24280 Z(I) = Z(I)+D(I)
24281 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24282 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24283 IF ( F2.GT.F3 ) D(I) =-D(I)
24284 20 CONTINUE
24285 F1 = MIN(F2,F3)
24286 F2 = MAX(F2,F3)
24287 Z(I) = Z(I)+D(I)
24288 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24289 IF ( F3.GT.F2 ) GOTO 20
24290 ZZ = Z(I)-D(I)
24291 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24292 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24293 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24294 IF ( F1.LE.F2 ) Z(I) = ZZ
24295 F2 = MAX(F1,F2)
24296 30 CONTINUE
24297 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24298
24299 IF(F2.GT.FF(NKON)) THEN
24300 FF(NKON) = MAX(F2,0.D0)
24301 XM1(NKON) = X1
24302 XM2(NKON) = X2
24303 PTM(NKON) = PT
24304 ZMX(1,NKON) = Z(1)
24305 ZMX(2,NKON) = Z(2)
24306 ZMX(3,NKON) = Z(3)
24307 DMX(1,NKON) = D(1)
24308 DMX(2,NKON) = D(2)
24309 DMX(3,NKON) = D(3)
24310 IMX(NKON) = IT
24311 IPO(NKON) = IST
24312 ENDIF
24313C
24314 50 CONTINUE
24315 35 CONTINUE
24316 40 CONTINUE
24317
24318C debug output
24319 IF(IDEB(38).GE.5) THEN
24320 WRITE(LO,'(/1X,A)')
24321 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24322 DO 60 I=1,NKM
24323 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24324 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24325 & DMX(2,I),DMX(3,I)
24326 60 CONTINUE
24327 ENDIF
24328
24329 DO 70 I=-1,Max_pro_2
24330 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24331 70 CONTINUE
24332
24333C debug output
24334 IF(IDEB(38).GE.5) THEN
24335 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24336 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24337 DO 80 I=-1,Max_pro_2
24338 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24339 MSPR = I
24340 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24341 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24342 PT = PTM(IFTAB(I))
24343 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24344 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24345 ENDIF
24346 80 CONTINUE
24347 ENDIF
24348
24349 END
24350
24351*$ CREATE PHO_HARWGI.FOR
24352*COPY PHO_HARWGI
24353CDECK ID>, PHO_HARWGI
24354 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24355C**********************************************************************
24356C
24357C auxiliary subroutine to find maximum of remaining weight
24358C
24359C input: ECMX current CMS energy
24360C PTCUT current pt cutoff
24361C NKON process label 1..5 resolved
24362C 6..7 direct particle 1
24363C 8..9 direct particle 2
24364C 10 double direct
24365C Z(3) transformed variable
24366C
24367C output: remaining weight
24368C
24369C**********************************************************************
24370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24371 SAVE
24372
24373 DIMENSION Z(3)
24374
24375 PARAMETER ( NKM = 10 )
24376 PARAMETER ( TINY = 1.D-30,
24377 & TINY6 = 1.D-06 )
24378
24379C input/output channels
24380 INTEGER LI,LO
24381 COMMON /POINOU/ LI,LO
24382C event debugging information
24383 INTEGER NMAXD
24384 PARAMETER (NMAXD=100)
24385 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24386 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24387 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24388 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24389C model switches and parameters
24390 CHARACTER*8 MDLNA
24391 INTEGER ISWMDL,IPAMDL
24392 DOUBLE PRECISION PARMDL
24393 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24394C data of c.m. system of Pomeron / Reggeon exchange
24395 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24396 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24397 & SIDP,CODP,SIFP,COFP
24398 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24399 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24400 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24401C currently activated parton density parametrizations
24402 CHARACTER*8 PDFNAM
24403 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24404 DOUBLE PRECISION PDFLAM,PDFQ2M
24405 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24406 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24407C hard scattering parameters used for most recent hard interaction
24408 INTEGER NFbeta,NF
24409 DOUBLE PRECISION ALQCD2,BQCD
24410 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24411C some hadron information, will be deleted in future versions
24412 INTEGER NFS
24413 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24414 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24415C scale parameters for parton model calculations
24416 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24417 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24418 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24419 & NQQAL,NQQALI,NQQALF,NQQPD
24420C data on most recent hard scattering
24421 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24422 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24423 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24424 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24425 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24426 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24427 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24428 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24429 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24430
24431 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24432 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24433
24434 FDIS = 0.D0
24435
24436 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24437 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24438C check input values
24439 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24440 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24441 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24442C transformations
24443 Y1 = EXP(ALNH*Z(1))
24444 IF(NKON.LE.5) THEN
24445C resolved kinematic
24446 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24447 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24448 X2 = X1-Y2
24449 X1 = MIN(X1,0.999999999999D0)
24450 X2 = MIN(X2,0.999999999999D0)
24451 ELSE IF(NKON.LE.7) THEN
24452C direct kinematic 1
24453 X1 = 1.D0
24454 X2 = MIN(Y1,0.999999999999D0)
24455 ELSE IF(NKON.LE.9) THEN
24456C direct kinematic 2
24457 X1 = MIN(Y1,0.999999999999D0)
24458 X2 = 1.D0
24459 ELSE
24460C double direct kinematic
24461 X1 = 1.D0
24462 X2 = 1.D0
24463 ENDIF
24464 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24465 V =-0.5D0+W*(Z(3)-0.5D0)
24466 U =-(1.D0+V)
24467 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24468
24469C set hard scale QQ for alpha and partondistr.
24470 IF ( NQQAL.EQ.1 ) THEN
24471 QQAL = AQQAL*PT*PT
24472 ELSEIF ( NQQAL.EQ.2 ) THEN
24473 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24474 ELSEIF ( NQQAL.EQ.3 ) THEN
24475 QQAL = AQQAL*Y1*ECMX*ECMX
24476 ELSEIF ( NQQAL.EQ.4 ) THEN
24477 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24478 ENDIF
24479 IF ( NQQPD.EQ.1 ) THEN
24480 QQPD = AQQPD*PT*PT
24481 ELSEIF ( NQQPD.EQ.2 ) THEN
24482 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24483 ELSEIF ( NQQPD.EQ.3 ) THEN
24484 QQPD = AQQPD*Y1*ECMX*ECMX
24485 ELSEIF ( NQQPD.EQ.4 ) THEN
24486 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24487 ENDIF
24488C
24489 IF(NKON.LE.5) THEN
24490 DO 10 N=1,5
24491 F(N) = 0.D0
24492 10 CONTINUE
24493C resolved processes
24494 ALPHA1 = PHO_ALPHAS(QQAL,3)
24495 ALPHA2 = ALPHA1
24496 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24497 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24498C calculate full distribution FDIS
24499 DO 20 I=1,NF
24500 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24501 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24502 F(4) = F(4)+PDA(I)+PDA(-I)
24503 F(5) = F(5)+PDB(I)+PDB(-I)
2450420 CONTINUE
24505 F(1) = PDA(0)*PDB(0)
24506 T = PDA(0)*F(5)+PDB(0)*F(4)
24507 F(5) = F(4)*F(5)-(F(2)+F(3))
24508 F(4) = T
24509 ELSE IF(NKON.LE.7) THEN
24510C direct processes particle 1
24511 IF(IDPDG1.EQ.22) THEN
24512 ALPHA1 = pho_alphae(QQAL)
24513 CH1 = 4.D0/9.D0
24514 CH2 = 3.D0/9.D0
24515 ELSE IF(IDPDG1.EQ.990) THEN
24516 ALPHA1 = PARMDL(74)
24517 CH1 = 1.D0
24518 CH2 = 0.D0
24519 ELSE
24520 FDIS = -1.D0
24521 RETURN
24522 ENDIF
24523 ALPHA2 = PHO_ALPHAS(QQAL,2)
24524 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24525 F(6) = 0.D0
24526 DO 30 I=1,NF
24527 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24528 30 CONTINUE
24529 F(7) = PDB(0)
24530 ELSE IF(NKON.LE.9) THEN
24531C direct processes particle 2
24532 ALPHA1 = PHO_ALPHAS(QQAL,1)
24533 IF(IDPDG2.EQ.22) THEN
24534 ALPHA2 = pho_alphae(QQAL)
24535 CH1 = 4.D0/9.D0
24536 CH2 = 3.D0/9.D0
24537 ELSE IF(IDPDG2.EQ.990) THEN
24538 ALPHA2 = PARMDL(74)
24539 CH1 = 1.D0
24540 CH2 = 0.D0
24541 ELSE
24542 FDIS = -1.D0
24543 RETURN
24544 ENDIF
24545 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24546 F(8) = 0.D0
24547 DO 40 I=1,NF
24548 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24549 40 CONTINUE
24550 F(9) = PDA(0)
24551 ELSE
24552C double direct process
24553 SSR = ECMX*ECMX
24554 IF(IDPDG1.EQ.22) THEN
24555 ALPHA1 = pho_alphae(SSR)
24556 ELSE IF(IDPDG1.EQ.990) THEN
24557 ALPHA1 = PARMDL(74)
24558 ELSE
24559 FDIS = -1.D0
24560 RETURN
24561 ENDIF
24562 IF(IDPDG2.EQ.22) THEN
24563 ALPHA2 = pho_alphae(SSR)
24564 ELSE IF(IDPDG2.EQ.990) THEN
24565 ALPHA2 = PARMDL(74)
24566 ELSE
24567 FDIS = -1.D0
24568 RETURN
24569 ENDIF
24570 F(10) = 1.D0
24571 ENDIF
24572
24573 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24574
24575C debug output
24576 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24577 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24578 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24579
24580 END
24581
24582*$ CREATE PHO_HARINI.FOR
24583*COPY PHO_HARINI
24584CDECK ID>, PHO_HARINI
24585 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24586C**********************************************************************
24587C
24588C initialize calculation of hard cross section
24589C
24590C must not be called during MC generation
24591C
24592C***********************************************************************
24593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24594 SAVE
24595
24596 PARAMETER ( DEPS = 1.D-10 )
24597
24598C input/output channels
24599 INTEGER LI,LO
24600 COMMON /POINOU/ LI,LO
24601C event debugging information
24602 INTEGER NMAXD
24603 PARAMETER (NMAXD=100)
24604 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24605 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24606 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24607 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24608C model switches and parameters
24609 CHARACTER*8 MDLNA
24610 INTEGER ISWMDL,IPAMDL
24611 DOUBLE PRECISION PARMDL
24612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24613C currently activated parton density parametrizations
24614 CHARACTER*8 PDFNAM
24615 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24616 DOUBLE PRECISION PDFLAM,PDFQ2M
24617 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24618 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24619C some constants
24620 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24621 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24622 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24623C scale parameters for parton model calculations
24624 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24625 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24626 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24627 & NQQAL,NQQALI,NQQALF,NQQPD
24628C data of c.m. system of Pomeron / Reggeon exchange
24629 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24630 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24631 & SIDP,CODP,SIFP,COFP
24632 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24633 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24634 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24635C obsolete cut-off information
24636 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24637 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24638C hard scattering parameters used for most recent hard interaction
24639 INTEGER NFbeta,NF
24640 DOUBLE PRECISION ALQCD2,BQCD
24641 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24642
24643 double precision pho_alphas
24644
24645 CHARACTER*20 RFLAG
24646
24647C set local Pomeron c.m. system data
24648 IDPDG1 = IDP1
24649 IDPDG2 = IDP2
24650 PVIRTP(1) = PV1
24651 PVIRTP(2) = PV2
24652C initialize PDFs
24653 CALL PHO_ACTPDF(IDPDG1,1)
24654 CALL PHO_ACTPDF(IDPDG2,2)
24655C initialize alpha_s calculation
24656 DUMMY = PHO_ALPHAS(0.D0,-4)
24657C initialize scales with defaults
24658 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24659 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24660 AQQAL = PARMDL(83)
24661 AQQALI = PARMDL(86)
24662 AQQALF = PARMDL(89)
24663 AQQPD = PARMDL(92)
24664 NQQAL = IPAMDL(83)
24665 NQQALI = IPAMDL(86)
24666 NQQALF = IPAMDL(89)
24667 NQQPD = IPAMDL(92)
24668 ELSE
24669 AQQAL = PARMDL(82)
24670 AQQALI = PARMDL(85)
24671 AQQALF = PARMDL(88)
24672 AQQPD = PARMDL(91)
24673 NQQAL = IPAMDL(82)
24674 NQQALI = IPAMDL(85)
24675 NQQALF = IPAMDL(88)
24676 NQQPD = IPAMDL(91)
24677 ENDIF
24678 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24679 AQQAL = PARMDL(82)
24680 AQQALI = PARMDL(85)
24681 AQQALF = PARMDL(88)
24682 AQQPD = PARMDL(91)
24683 NQQAL = IPAMDL(82)
24684 NQQALI = IPAMDL(85)
24685 NQQALF = IPAMDL(88)
24686 NQQPD = IPAMDL(91)
24687 ELSE
24688 AQQAL = PARMDL(81)
24689 AQQALI = PARMDL(84)
24690 AQQALF = PARMDL(87)
24691 AQQPD = PARMDL(90)
24692 NQQAL = IPAMDL(81)
24693 NQQALI = IPAMDL(84)
24694 NQQALF = IPAMDL(87)
24695 NQQPD = IPAMDL(90)
24696 ENDIF
24697 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24698 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24699 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24700 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24701 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24702 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24703 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24704 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24705 AQQAL = PARMDL(109+IP)
24706 AQQALI = PARMDL(113+IP)
24707 AQQALF = PARMDL(117+IP)
24708 AQQPD = PARMDL(121+IP)
24709 NQQAL = IPAMDL(64+IP)
24710 NQQALI = IPAMDL(68+IP)
24711 NQQALF = IPAMDL(72+IP)
24712 NQQPD = IPAMDL(76+IP)
24713 PTCUT(1) = PARMDL(36)
24714 PTCUT(2) = PARMDL(37)
24715 PTCUT(3) = PARMDL(38)
24716 PTCUT(4) = PARMDL(39)
24717 PTANO(1) = PARMDL(130)
24718 PTANO(2) = PARMDL(131)
24719 PTANO(3) = PARMDL(132)
24720 PTANO(4) = PARMDL(133)
24721 RFLAG = '(energy-independent)'
24722 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24723
24724C write out all settings
24725 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24726 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24727 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24728 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24729 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
247301050 FORMAT(/,
24731 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24732 & 5X,'particle 1 / particle 2:',2I8,/,
24733 & 5X,'min. PT :',F7.1,2X,A,/,
24734 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24735 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24736 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24737 & 5X,'max. number of active flavours NF :',I3,/,
24738 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24739 ENDIF
24740
24741 END
24742
24743*$ CREATE PHO_HARINT.FOR
24744*COPY PHO_HARINT
24745CDECK ID>, PHO_HARINT
24746 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24747C**********************************************************************
24748C
24749C interpolate cross sections and weights for hard scattering
24750C
24751C input: IPP particle combination (neg. for add. user cuts)
24752C ECM CMS energy (GeV)
24753C P2V1/2 particle virtualities (pos., GeV**2)
24754C I1 first subprocess to calculate
24755C I2 last subprocess to calculate
24756C <-1 only scales and cutoffs calculated
24757C K1 first variable to calculate
24758C K2 last variable to calculate
24759C MSPOM cross sections to use for pt distribution
24760C 0 reggeon
24761C >0 pomeron
24762C
24763C for K1 < 3 the soft pt distribution is also calculated
24764C
24765C output: interpolated values in HWgx, HSig, Hdpt
24766C
24767C***********************************************************************
24768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24769 SAVE
24770
24771 PARAMETER ( DEPS = 1.D-15,
24772 & DEPS2 = 2.D-15 )
24773
24774C input/output channels
24775 INTEGER LI,LO
24776 COMMON /POINOU/ LI,LO
24777C event debugging information
24778 INTEGER NMAXD
24779 PARAMETER (NMAXD=100)
24780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24784C model switches and parameters
24785 CHARACTER*8 MDLNA
24786 INTEGER ISWMDL,IPAMDL
24787 DOUBLE PRECISION PARMDL
24788 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24789C Reggeon phenomenology parameters
24790 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24791 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24792 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24793 & ALREG,ALREGP,GR(2),B0REG(2),
24794 & GPPP,GPPR,B0PPP,B0PPR,
24795 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24796C parameters of 2x2 channel model
24797 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24798 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24799C data needed for soft-pt calculation
24800 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24801 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24802C scale parameters for parton model calculations
24803 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24804 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24805 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24806 & NQQAL,NQQALI,NQQALF,NQQPD
24807C obsolete cut-off information
24808 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24809 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24810C event weights and generated cross section
24811 INTEGER IPOWGC,ISWCUT,IVWGHT
24812 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24813 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24814 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24815C parameters for DGLAP backward evolution in ISR
24816 INTEGER NFSISR
24817 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24818 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24819C hard cross sections and MC selection weights
24820 INTEGER Max_pro_2
24821 PARAMETER ( Max_pro_2 = 16 )
24822 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24823 & MH_acc_1,MH_acc_2
24824 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24825 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24826 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24827 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24828 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24829 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24830C interpolation tables for hard cross section and MC selection weights
24831 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24832 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24833 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24834 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24835 & HQ2a_tab,HQ2b_tab,HEcm_tab
24836 COMMON /POHTAB/
24837 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24838 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24839 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24840 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24841 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24842 & HEcm_tab(1:Max_tab_E,0:4),
24843 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24844C data on most recent hard scattering
24845 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24846 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24847 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24848 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24849 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24850 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24851 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24852 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24853 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24854C energy-interpolation table
24855 INTEGER IEETA2
24856 PARAMETER ( IEETA2 = 20 )
24857 INTEGER ISIMAX
24858 DOUBLE PRECISION SIGTAB,SIGECM
24859 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24860
24861 DOUBLE PRECISION XP,PTS
24862 DIMENSION XP(2),PTS(0:2,2)
24863
24864 INTEGER IV
24865 DIMENSION IV(2)
24866
24867 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24868 & 'PHO_HARINT: called with ',
24869 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24870 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24871
24872 IP = ABS(IPP)
24873 IF(IPP.GT.0) THEN
24874C default minimum bias cutoff
24875 PTCUT(IP) = pho_ptcut(ECM,IP)
24876 ELSE
24877C user defined additional cutoff
24878 PTCUT(IP) = HSWCUT(4+IP)
24879 ENDIF
24880 PTWANT = PTCUT(IP)
24881
24882C ISR cutoffs
24883 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24884 Q2MISR(1) = MAX(P2V1,Q2CUT)
24885 Q2MISR(2) = MAX(P2V2,Q2CUT)
24886C cutoff for direct photon contribution to photon PDF
24887 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24888 PTA1 = PTANO(IP)
24889C scales for hard scattering
24890 AQQAL = PARMDL(109+IP)
24891 AQQALI = PARMDL(113+IP)
24892 AQQALF = PARMDL(117+IP)
24893 AQQPD = PARMDL(121+IP)
24894 NQQAL = IPAMDL(64+IP)
24895 NQQALI = IPAMDL(68+IP)
24896 NQQALF = IPAMDL(72+IP)
24897 NQQPD = IPAMDL(76+IP)
24898 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24899 & 'PHO_HARINT: scales:',
24900 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24901
24902 IF(I2.LT.-1) RETURN
24903
24904 IL = IP
24905 IF(IPP.LT.0) IL = 0
24906
24907C double-log interpolation
24908 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24909 DO 50 M=I1,I2
24910 Hfac(M) = 0.D0
24911 HWgx(M) = 0.D0
24912 HSig(M) = 0.D0
24913 Hdpt(M) = 0.D0
24914 50 CONTINUE
24915 ELSE
24916 I=1
24917 310 CONTINUE
24918 I = I+1
24919 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24920
24921 Ia = 1
24922 Ib = 1
24923 fac = LOG(ECM/HEcm_tab(I-1,IL))
24924 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24925 do M=I1,I2
24926C factor due to phase space integration
24927 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24928 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24929 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24930 XX = EXP(XX)
24931 IF(XX.LT.DEPS2) XX = 0.D0
24932 Hfac(M) = XX
24933C max. weight
24934 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24935 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24936 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24937 XX = EXP(XX)
24938 IF(XX.LT.DEPS2) XX = 0.D0
24939 HWgx(M) = XX*1.2D0
24940C hard cross section
24941 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24942 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24943 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24944 XX = EXP(XX)
24945 IF(XX.LT.DEPS2) XX = 0.D0
24946 HSig(M) = XX
24947C differential hard cross section
24948 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24949 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24950 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24951 XX = EXP(XX)
24952 IF(XX.LT.DEPS2) XX = 0.D0
24953 Hdpt(M) = XX
24954 enddo
24955 ENDIF
24956
24957 IF((K1.LT.3).AND.(K2.GE.3)) THEN
24958C cross check
24959 IF((I1.GT.9).OR.(I2.LT.9)) THEN
24960 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24961 & 'hard cross section not calculated ',I1,I2
24962 ENDIF
24963 SIGH = HSig(9)
24964 DSIGHP = Hdpt(9)
24965C load soft cross sections from interpolation table
24966 IF(ECM.LE.SIGECM(IP,1)) THEN
24967 L1 = 1
24968 L2 = 1
24969 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24970 DO 55 I=2,ISIMAX
24971 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24972 55 CONTINUE
24973 205 CONTINUE
24974 L1 = I-1
24975 L2 = I
24976 ELSE
24977 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
24978 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
24979 & IP,ECM,SIGECM(IP,ISIMAX)
24980 CALL PHO_PREVNT(-1)
24981 L1 = ISIMAX-1
24982 L2 = ISIMAX
24983 ENDIF
24984 FAC2=0.D0
24985 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
24986 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
24987 FAC1=1.D0-FAC2
24988 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
24989 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
24990
24991 FS = FPS(IP)
24992 FH = FPH(IP)
24993 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
24994 ENDIF
24995
24996 300 CONTINUE
24997
24998C debug output
24999 IF(IDEB(58).GE.15) THEN
25000 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25001 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25002 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25003 DO 162 M=I1,I2
25004 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25005 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25006 162 CONTINUE
25007 ENDIF
25008
25009 END
25010
25011*$ CREATE PHO_PTCUT.FOR
25012*COPY PHO_PTCUT
25013 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25014C***********************************************************************
25015C
25016C calculate energy-dependent transverse momentum cutoff
25017C
25018C***********************************************************************
25019 IMPLICIT NONE
25020 SAVE
25021
25022 double precision ECM
25023 integer IP
25024
25025C input/output channels
25026 INTEGER LI,LO
25027 COMMON /POINOU/ LI,LO
25028C event debugging information
25029 INTEGER NMAXD
25030 PARAMETER (NMAXD=100)
25031 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25032 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25033 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25034 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25035C model switches and parameters
25036 CHARACTER*8 MDLNA
25037 INTEGER ISWMDL,IPAMDL
25038 DOUBLE PRECISION PARMDL
25039 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25040
25041 pho_ptcut = PARMDL(35+IP)
25042
25043 IF(IPAMDL(7).EQ.1) THEN
25044C Bopp et al. type (DPMJET)
25045 pho_ptcut = PARMDL(35+IP)
25046 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25047 ELSE IF(IPAMDL(7).EQ.2) THEN
25048C Gribov-Levin-Ryskin type
25049 pho_ptcut = PARMDL(35+IP)
25050 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25051 ENDIF
25052
25053 END
25054
25055*$ CREATE PHO_HARMCI.FOR
25056*COPY PHO_HARMCI
25057CDECK ID>, PHO_HARMCI
25058 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25059C**********************************************************************
25060C
25061C initialize MC sampling and calculate hard cross section
25062C
25063C input: IP particle combination (neg. number for user cut)
25064C EMAXF maximum CMS energy for
25065C interpolation table in reference to PTCUT(1..4)
25066C
25067C***********************************************************************
25068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25069 SAVE
25070
25071 PARAMETER (DEPS = 1.D-10,
25072 & PLARGE = 1.D20 )
25073
25074C input/output channels
25075 INTEGER LI,LO
25076 COMMON /POINOU/ LI,LO
25077C event debugging information
25078 INTEGER NMAXD
25079 PARAMETER (NMAXD=100)
25080 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25081 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25082 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25083 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25084C some constants
25085 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25086 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25087 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25088C global event kinematics and particle IDs
25089 INTEGER IFPAP,IFPAB
25090 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25091 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25092C data of c.m. system of Pomeron / Reggeon exchange
25093 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25094 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25095 & SIDP,CODP,SIFP,COFP
25096 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25097 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25098 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25099C model switches and parameters
25100 CHARACTER*8 MDLNA
25101 INTEGER ISWMDL,IPAMDL
25102 DOUBLE PRECISION PARMDL
25103 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25104C obsolete cut-off information
25105 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25106 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25107C scale parameters for parton model calculations
25108 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25109 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25110 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25111 & NQQAL,NQQALI,NQQALF,NQQPD
25112C names of hard scattering processes
25113 INTEGER Max_pro_1
25114 PARAMETER ( Max_pro_1 = 16 )
25115 CHARACTER*18 PROC
25116 COMMON /POHPRO/ PROC(0:Max_pro_1)
25117C hard cross sections and MC selection weights
25118 INTEGER Max_pro_2
25119 PARAMETER ( Max_pro_2 = 16 )
25120 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25121 & MH_acc_1,MH_acc_2
25122 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25123 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25124 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25125 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25126 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25127 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25128C interpolation tables for hard cross section and MC selection weights
25129 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25130 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25131 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25132 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25133 & HQ2a_tab,HQ2b_tab,HEcm_tab
25134 COMMON /POHTAB/
25135 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25136 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25137 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25138 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25139 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25140 & HEcm_tab(1:Max_tab_E,0:4),
25141 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25142C event weights and generated cross section
25143 INTEGER IPOWGC,ISWCUT,IVWGHT
25144 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25145 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25146 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25147
25148 COMPLEX*16 DSIG
25149 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25150
25151C initialization for all pt cutoffs
25152 I = ABS(IP)
25153 IL = I
25154 IF(IP.LT.0) THEN
25155 IL = 0
25156 PTC = HSWCUT(4+I)
25157 else
25158 PTC = pho_ptcut(parmdl(19),I)
25159 ENDIF
25160
25161C skip unassigned PTCUT
25162 IF(PTC.LT.0.5D0) GOTO 1000
25163
25164 IH_Q2a_up(I) = 1
25165 IH_Q2b_up(I) = 1
25166 do ib=1,Max_tab_Q2
25167 do ia=1,Max_tab_Q2
25168 do ie=1,Max_tab_E
25169 do m=-1,Max_pro_2
25170 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25171 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25172 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25173 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25174 enddo
25175 enddo
25176 enddo
25177 enddo
25178
25179 ELLOW = LOG(2.05*PTC)
25180 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25181C energy too low
25182 IF(DELTA.LE.0.D0) GOTO 1000
25183
25184C switch between external particles and Pomeron
25185 IF(I.EQ.4) THEN
25186 IDP1 = 990
25187 PV1 = 0.D0
25188 IDP2 = 990
25189 PV2 = 0.D0
25190 ELSE IF(I.EQ.3) THEN
25191 IDP1 = IFPAP(2)
25192 PV1 = PVIRT(2)
25193 IDP2 = 990
25194 PV2 = 0.D0
25195 ELSE IF(I.EQ.2) THEN
25196 IDP1 = IFPAP(1)
25197 PV1 = PVIRT(1)
25198 IDP2 = 990
25199 PV2 = 0.D0
25200 ELSE
25201 IDP1 = IFPAP(1)
25202 PV1 = PVIRT(1)
25203 IDP2 = IFPAP(2)
25204 PV2 = PVIRT(2)
25205 ENDIF
25206
25207C initialize PT scales
25208 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25209 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25210 FPS(I) = PARMDL(105)
25211 FPH(I) = PARMDL(106)
25212 ELSE
25213 FPS(I) = PARMDL(103)
25214 FPH(I) = PARMDL(104)
25215 ENDIF
25216 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25217 FPS(I) = PARMDL(103)
25218 FPH(I) = PARMDL(104)
25219 ELSE
25220 FPS(I) = PARMDL(101)
25221 FPH(I) = PARMDL(102)
25222 ENDIF
25223
25224C initialize hard scattering
25225 IF(IP.GT.0) THEN
25226 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25227 ELSE
25228 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25229 ENDIF
25230
25231C energy/virtuality grid
25232 do Ie=1,IH_Ecm_up(IL)
25233 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25234 enddo
25235 do Ia=1,IH_Q2a_up(IL)
25236 HQ2a_tab(Ia,IL) = 0.D0
25237 enddo
25238 do Ib=1,IH_Q2b_up(IL)
25239 HQ2b_tab(Ib,IL) = 0.D0
25240 enddo
25241
25242C initialization for several energies and particle virtualities
25243 do Ie=1,IH_Ecm_up(IL)
25244 do Ia=1,IH_Q2a_up(IL)
25245 do Ib=1,IH_Q2b_up(IL)
25246
25247 EE = HEcm_tab(IE,IL)
25248 Q2a = HQ2a_tab(Ia,IL)
25249 Q2b = HQ2b_tab(Ib,IL)
25250 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25251 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25252 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25253 & PTCUT(I),EE,IDPDG1,IDPDG2
25254 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25255 CALL PHO_HARFAC(PTCUT(I),EE)
25256 CALL PHO_HARWGX(PTCUT(I),EE)
25257 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25258 IF(IDEB(8).GE.10) THEN
25259 WRITE(LO,'(1X,A,/,1X,A)')
25260 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25261 & '------------------------------------------------'
25262 DO M=0,Max_pro_2
25263 WRITE(LO,'(10X,A,1P2E14.4)')
25264 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25265 ENDDO
25266 ENDIF
25267
25268C store in interpolation tables
25269 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25270 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25271 do M=0,Max_pro_2
25272 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25273 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25274 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25275 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25276 enddo
25277
25278C summed quantities
25279 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25280 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25281 do M=1,8
25282 IF(MH_pro_on(M,I).GT.0) THEN
25283 HSig_tab(9,IE,Ia,Ib,IL) =
25284 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25285 Hdpt_tab(9,IE,Ia,Ib,IL) =
25286 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25287 ENDIF
25288 enddo
25289 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25290 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25291 do M=10,14
25292 IF(MH_pro_on(M,I).GT.0) THEN
25293 HSig_tab(15,IE,Ia,Ib,IL) =
25294 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25295 Hdpt_tab(15,IE,Ia,Ib,IL) =
25296 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25297 ENDIF
25298 enddo
25299 HSig_tab(0,IE,Ia,Ib,IL) =
25300 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25301 Hdpt_tab(0,IE,Ia,Ib,IL) =
25302 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25303
25304 enddo
25305 enddo
25306 enddo
25307
25308C debug output of weights
25309 1000 CONTINUE
25310 IF(IDEB(8).GE.5) THEN
25311 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25312 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25313 & IDPDG1,IDPDG2,IP,PTCUT(I),
25314 & '------------------------------------------'
25315 DO M=-1,Max_pro_2
25316 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25317 WRITE(LO,'(2X,A,I3,2I7)')
25318 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25319 & M,IDPDG1,IDPDG2
25320 do k=1,IH_Ecm_up(IL)
25321 do ia=1,IH_Q2a_up(IL)
25322 do ib=1,IH_Q2b_up(IL)
25323 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25324 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25325 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25326 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25327 enddo
25328 enddo
25329 enddo
25330 512 CONTINUE
25331 ENDDO
25332 ENDIF
25333
25334 END
25335
25336*$ CREATE PHO_HARXR3.FOR
25337*COPY PHO_HARXR3
25338CDECK ID>, PHO_HARXR3
25339 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25340C**********************************************************************
25341C
25342C differential cross section DSIG/(DETAC*DETAD*DPT)
25343C
25344C input: ECMH CMS energy
25345C PT parton PT
25346C ETAC pseudorapidity of parton C
25347C ETAD pseudorapidity of parton D
25348C
25349C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25350C
25351C**********************************************************************
25352 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25353 SAVE
25354
25355 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25356
25357 PARAMETER ( Max_pro_2 = 16 )
25358 COMPLEX*16 DSIGMC
25359 DIMENSION DSIGMC(0:Max_pro_2)
25360 DIMENSION DSIGM(0:Max_pro_2)
25361
25362C input/output channels
25363 INTEGER LI,LO
25364 COMMON /POINOU/ LI,LO
25365C some constants
25366 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25367 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25368 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25369C Reggeon phenomenology parameters
25370 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25371 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25372 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25373 & ALREG,ALREGP,GR(2),B0REG(2),
25374 & GPPP,GPPR,B0PPP,B0PPR,
25375 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25376C currently activated parton density parametrizations
25377 CHARACTER*8 PDFNAM
25378 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25379 DOUBLE PRECISION PDFLAM,PDFQ2M
25380 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25381 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25382C hard scattering parameters used for most recent hard interaction
25383 INTEGER NFbeta,NF
25384 DOUBLE PRECISION ALQCD2,BQCD
25385 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25386C scale parameters for parton model calculations
25387 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25388 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25389 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25390 & NQQAL,NQQALI,NQQALF,NQQPD
25391
25392 DOUBLE PRECISION PHO_ALPHAS
25393 DIMENSION PDA(-6:6),PDB(-6:6)
25394
25395 DO 10 I=1,9
25396 DSIGMC(I) = CMPLX(0.D0,0.D0)
25397 DSIGM(I) = 0.D0
2539810 CONTINUE
25399
25400 EC = EXP(ETAC)
25401 ED = EXP(ETAD)
25402C kinematic conversions
25403 XA = PT*(EC+ED)/ECMH
25404 XB = XA/(EC*ED)
25405 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25406 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25407 RETURN
25408 ENDIF
25409 SP = XA*XB*ECMH*ECMH
25410 UP =-ECMH*PT*EC*XB
25411 UP = UP/SP
25412 TP =-(1.D0+UP)
25413 UU = UP*UP
25414 TT = TP*TP
25415C set hard scale QQ for alpha and partondistr.
25416 IF ( NQQAL.EQ.1 ) THEN
25417 QQAL = AQQAL*PT*PT
25418 ELSEIF ( NQQAL.EQ.2 ) THEN
25419 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25420 ELSEIF ( NQQAL.EQ.3 ) THEN
25421 QQAL = AQQAL*SP
25422 ELSEIF ( NQQAL.EQ.4 ) THEN
25423 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25424 ENDIF
25425 IF ( NQQPD.EQ.1 ) THEN
25426 QQPD = AQQPD*PT*PT
25427 ELSEIF ( NQQPD.EQ.2 ) THEN
25428 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25429 ELSEIF ( NQQPD.EQ.3 ) THEN
25430 QQPD = AQQPD*SP
25431 ELSEIF ( NQQPD.EQ.4 ) THEN
25432 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25433 ENDIF
25434
25435 ALPHA = PHO_ALPHAS(QQAL,3)
25436 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25437C parton distributions (times x)
25438 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25439 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25440 S1 = PDA(0)*PDB(0)
25441 S2 = 0.D0
25442 S3 = 0.D0
25443 S4 = 0.D0
25444 S5 = 0.D0
25445 DO 20 I=1,NF
25446 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25447 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25448 S4 = S4+PDA(I)+PDA(-I)
25449 S5 = S5+PDB(I)+PDB(-I)
2545020 CONTINUE
25451C partial cross sections (including color and symmetry factors)
25452C resolved photon matrix elements (light quarks)
25453 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25454 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25455 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25456 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25457 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25458 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25459 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25460 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25461 & (8.D0/27.D0)/(UP*TP))
25462C
25463 DSIGM(1) = FACTOR*DSIGM(1)*S1
25464 DSIGM(2) = FACTOR*DSIGM(2)*S2
25465 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25466 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25467 DSIGM(5) = FACTOR*DSIGM(5)*S2
25468 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25469 DSIGM(7) = FACTOR*DSIGM(7)*S3
25470 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25471C complex part
25472 X=ABS(TP-UP)
25473 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25474C
25475 DO 50 I=1,8
25476 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25477 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25478 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25479 50 CONTINUE
25480 END
25481
25482*$ CREATE PHO_HARXR2.FOR
25483*COPY PHO_HARXR2
25484CDECK ID>, PHO_HARXR2
25485 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25486C**********************************************************************
25487C
25488C differential cross section DSIG/(DETAC*DPT)
25489C
25490C input: ECMH CMS energy
25491C PT parton PT
25492C ETAC pseudorapidity of parton C
25493C
25494C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25495C
25496C**********************************************************************
25497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25498 SAVE
25499
25500 PARAMETER ( TINY= 1.D-20 )
25501
25502 PARAMETER ( Max_pro_2 = 16 )
25503 COMPLEX*16 DSIGMC
25504 DIMENSION DSIGMC(0:Max_pro_2)
25505
25506C input/output channels
25507 INTEGER LI,LO
25508 COMMON /POINOU/ LI,LO
25509C integration precision for hard cross sections (obsolete)
25510 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25511 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25512
25513 COMPLEX*16 DSIG1
25514 DIMENSION DSIG1(0:Max_pro_2)
25515 DIMENSION ABSZ(32),WEIG(32)
25516
25517 DO 10 M=1,9
25518 DSIGMC(M) = CMPLX(0.D0,0.D0)
25519 DSIG1(M) = 0.D0
2552010 CONTINUE
25521C
25522 EC = EXP(ETAC)
25523 ARG = ECMH/PT
25524 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25525 EDU = LOG(ARG-EC)
25526 EDL =-LOG(ARG-1.D0/EC)
25527 NPOINT = NGAUET
25528 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25529 DO 30 I=1,NPOINT
25530 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25531 DO 20 M=1,9
25532 PCTRL= DREAL(DSIG1(M))/TINY
25533 IF( PCTRL.GE.1.D0 ) THEN
25534 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25535 ENDIF
2553620 CONTINUE
2553730 CONTINUE
25538 END
25539
25540*$ CREATE PHO_HARXD2.FOR
25541*COPY PHO_HARXD2
25542CDECK ID>, PHO_HARXD2
25543 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25544C**********************************************************************
25545C
25546C differential cross section DSIG/(DETAC*DPT) for direct processes
25547C
25548C input: ECMH CMS energy of scattering system
25549C PT parton PT
25550C ETAC pseudorapidity of parton C
25551C
25552C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25553C
25554C**********************************************************************
25555 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25556 SAVE
25557
25558 PARAMETER ( Max_pro_2 = 16 )
25559 COMPLEX*16 DSIGMC
25560 DIMENSION DSIGMC(0:Max_pro_2)
25561 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25562
25563C input/output channels
25564 INTEGER LI,LO
25565 COMMON /POINOU/ LI,LO
25566C model switches and parameters
25567 CHARACTER*8 MDLNA
25568 INTEGER ISWMDL,IPAMDL
25569 DOUBLE PRECISION PARMDL
25570 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25571C data of c.m. system of Pomeron / Reggeon exchange
25572 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25573 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25574 & SIDP,CODP,SIFP,COFP
25575 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25576 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25577 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25578C Reggeon phenomenology parameters
25579 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25580 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25581 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25582 & ALREG,ALREGP,GR(2),B0REG(2),
25583 & GPPP,GPPR,B0PPP,B0PPR,
25584 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25585C currently activated parton density parametrizations
25586 CHARACTER*8 PDFNAM
25587 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25588 DOUBLE PRECISION PDFLAM,PDFQ2M
25589 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25590 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25591C hard scattering parameters used for most recent hard interaction
25592 INTEGER NFbeta,NF
25593 DOUBLE PRECISION ALQCD2,BQCD
25594 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25595C some hadron information, will be deleted in future versions
25596 INTEGER NFS
25597 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25598 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25599C scale parameters for parton model calculations
25600 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25601 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25602 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25603 & NQQAL,NQQALI,NQQALF,NQQPD
25604C some constants
25605 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25606 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25607 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25608
25609 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25610 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25611
25612* ONE32=1.D0/9.D0
25613* TWO32=4.D0/9.D0
25614 DO 10 I=10,13
25615 DSIGMC(I) = CMPLX(0.D0,0.D0)
25616 DSIGM(I) = 0.D0
25617 10 CONTINUE
25618 DSIGMC(15) = CMPLX(0.D0,0.D0)
25619 DSIGM(15) = 0.D0
25620
25621C direct particle 1
25622 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25623 EC = EXP(ETAC)
25624 ED = ECMH/PT-EC
25625C kinematic conversions
25626 XA = 1.D0
25627 XB = 1.D0/(EC*ED)
25628 IF ( XB.GE.1.D0 ) THEN
25629 WRITE(LO,'(/1X,A,2E12.4)')
25630 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25631 RETURN
25632 ENDIF
25633 SP = XA*XB*ECMH*ECMH
25634 UP =-ECMH*PT*EC*XB
25635 UP = UP/SP
25636 TP =-(1.D0+UP)
25637 UU = UP*UP
25638 TT = TP*TP
25639C set hard scale QQ for alpha and partondistr.
25640 IF ( NQQAL.EQ.1 ) THEN
25641 QQAL = AQQAL*PT*PT
25642 ELSEIF ( NQQAL.EQ.2 ) THEN
25643 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25644 ELSEIF ( NQQAL.EQ.3 ) THEN
25645 QQAL = AQQAL*SP
25646 ELSEIF ( NQQAL.EQ.4 ) THEN
25647 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25648 ENDIF
25649 IF ( NQQPD.EQ.1 ) THEN
25650 QQPD = AQQPD*PT*PT
25651 ELSEIF ( NQQPD.EQ.2 ) THEN
25652 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25653 ELSEIF ( NQQPD.EQ.3 ) THEN
25654 QQPD = AQQPD*SP
25655 ELSEIF ( NQQPD.EQ.4 ) THEN
25656 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25657 ENDIF
25658
25659 ALPHA2 = PHO_ALPHAS(QQAL,2)
25660 IF(IDPDG1.EQ.22) THEN
25661 ALPHA1 = pho_alphae(QQAL)
25662 ELSE IF(IDPDG1.EQ.990) THEN
25663 ALPHA1 = PARMDL(74)
25664 ENDIF
25665 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25666C parton distribution (times x)
25667 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25668 S1 = PDB(0)
25669C charge counting
25670 S2 = 0.D0
25671 S3 = 0.D0
25672 IF(IDPDG1.EQ.22) THEN
25673 DO 20 I=1,NF
25674* IF(MOD(I,2).EQ.0) THEN
25675* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25676* S3 = S3 + TWO32
25677* ELSE
25678* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25679* S3 = S3 + ONE32
25680* ENDIF
25681 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25682 S3 = S3 + Q_ch2(I)
25683 20 CONTINUE
25684 ELSE IF(IDPDG1.EQ.990) THEN
25685 DO 25 I=1,NF
25686 S2 = S2 + PDB(I)+PDB(-I)
25687 25 CONTINUE
25688 S3 = NF
25689 ENDIF
25690C partial cross sections (including color and symmetry factors)
25691C direct photon matrix elements
25692 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25693 DSIGM(11) = (UU+TT)/(UP*TP)
25694C
25695 DSIGM(10) = FACTOR*DSIGM(10)*S2
25696 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25697C complex part
25698 X=ABS(TP-UP)
25699 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25700C
25701 DO 50 I=10,11
25702 IF(DSIGM(I).LT.0.D0) THEN
25703 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25704 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25705 DSIGM(I) = 0.D0
25706 ENDIF
25707 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25708 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25709 50 CONTINUE
25710 ENDIF
25711C
25712C direct particle 2
25713 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25714 EC = EXP(ETAC)
25715 ED = 1.D0/(ECMH/PT-1.D0/EC)
25716C kinematic conversions
25717 XA = PT*(EC+ED)/ECMH
25718 XB = 1.D0
25719 IF ( XA.GE.1.D0 ) THEN
25720 WRITE(LO,'(/1X,A,2E12.4)')
25721 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25722 RETURN
25723 ENDIF
25724 SP = XA*XB*ECMH*ECMH
25725 UP =-ECMH*PT*EC*XB
25726 UP = UP/SP
25727 TP =-(1.D0+UP)
25728 UU = UP*UP
25729 TT = TP*TP
25730C set hard scale QQ for alpha and partondistr.
25731 IF ( NQQAL.EQ.1 ) THEN
25732 QQAL = AQQAL*PT*PT
25733 ELSEIF ( NQQAL.EQ.2 ) THEN
25734 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25735 ELSEIF ( NQQAL.EQ.3 ) THEN
25736 QQAL = AQQAL*SP
25737 ELSEIF ( NQQAL.EQ.4 ) THEN
25738 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25739 ENDIF
25740 IF ( NQQPD.EQ.1 ) THEN
25741 QQPD = AQQPD*PT*PT
25742 ELSEIF ( NQQPD.EQ.2 ) THEN
25743 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25744 ELSEIF ( NQQPD.EQ.3 ) THEN
25745 QQPD = AQQPD*SP
25746 ELSEIF ( NQQPD.EQ.4 ) THEN
25747 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25748 ENDIF
25749
25750 ALPHA1 = PHO_ALPHAS(QQAL,1)
25751 IF(IDPDG2.EQ.22) THEN
25752 ALPHA2 = pho_alphae(QQAL)
25753 ELSE IF(IDPDG2.EQ.990) THEN
25754 ALPHA2 = PARMDL(74)
25755 ENDIF
25756 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25757C parton distribution (times x)
25758 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25759 S1 = PDA(0)
25760C charge counting
25761 S2 = 0.D0
25762 S3 = 0.D0
25763 IF(IDPDG2.EQ.22) THEN
25764 DO 70 I=1,NF
25765* IF(MOD(I,2).EQ.0) THEN
25766* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25767* S3 = S3 + TWO32
25768* ELSE
25769* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25770* S3 = S3 + ONE32
25771* ENDIF
25772 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25773 S3 = S3 + Q_ch2(I)
25774 70 CONTINUE
25775 ELSE IF(IDPDG2.EQ.990) THEN
25776 DO 75 I=1,NF
25777 S2 = S2 + PDA(I)+PDA(-I)
25778 75 CONTINUE
25779 S3 = NF
25780 ENDIF
25781C partial cross sections (including color and symmetry factors)
25782C direct photon matrix elements
25783 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25784 DSIGM(13) = (UU+TT)/(UP*TP)
25785C
25786 DSIGM(12) = FACTOR*DSIGM(12)*S2
25787 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25788C complex part
25789 X=ABS(TP-UP)
25790 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25791C
25792 DO 80 I=12,13
25793 IF(DSIGM(I).LT.0.D0) THEN
25794 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25795 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25796 DSIGM(I) = 0.D0
25797 ENDIF
25798 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25799 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25800 80 CONTINUE
25801 ENDIF
25802 END
25803
25804*$ CREATE PHO_HARXPT.FOR
25805*COPY PHO_HARXPT
25806CDECK ID>, PHO_HARXPT
25807 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25808C**********************************************************************
25809C
25810C differential cross section DSIG/DPT
25811C
25812C input: ECMH CMS energy of scattering system
25813C PT parton PT
25814C IPRO 1 resolved processes
25815C 2 direct processes
25816C 3 resolved and direct processes
25817C
25818C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25819C
25820C**********************************************************************
25821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25822 SAVE
25823
25824 PARAMETER ( Max_pro_2 = 16 )
25825 COMPLEX*16 DSIGMC
25826 DIMENSION DSIGMC(0:Max_pro_2)
25827 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25828
25829C input/output channels
25830 INTEGER LI,LO
25831 COMMON /POINOU/ LI,LO
25832C some constants
25833 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25834 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25835 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25836C model switches and parameters
25837 CHARACTER*8 MDLNA
25838 INTEGER ISWMDL,IPAMDL
25839 DOUBLE PRECISION PARMDL
25840 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25841C data of c.m. system of Pomeron / Reggeon exchange
25842 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25843 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25844 & SIDP,CODP,SIFP,COFP
25845 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25846 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25847 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25848C Reggeon phenomenology parameters
25849 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25850 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25851 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25852 & ALREG,ALREGP,GR(2),B0REG(2),
25853 & GPPP,GPPR,B0PPP,B0PPR,
25854 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25855C integration precision for hard cross sections (obsolete)
25856 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25857 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25858C hard scattering parameters used for most recent hard interaction
25859 INTEGER NFbeta,NF
25860 DOUBLE PRECISION ALQCD2,BQCD
25861 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25862C some hadron information, will be deleted in future versions
25863 INTEGER NFS
25864 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25865 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25866
25867 double precision pho_alphae
25868
25869 COMPLEX*16 DSIG1
25870 DIMENSION DSIG1(0:Max_pro_2)
25871 DIMENSION ABSZ(32),WEIG(32)
25872
25873 DO 10 M=0,Max_pro_2
25874 DSIGMC(M) = CMPLX(0.D0,0.D0)
25875 DSIG1(M) = CMPLX(0.D0,0.D0)
25876 10 CONTINUE
25877
25878C resolved and direct processes
25879 AMT = 2.D0*PT/ECMH
25880 IF ( AMT.GE.1.D0 ) RETURN
25881 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25882 ECL = -ECU
25883 NPOINT = NGAUET
25884 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25885 DO 30 I=1,NPOINT
25886 DSIG1(9) = CMPLX(0.D0,0.D0)
25887 DSIG1(15) = CMPLX(0.D0,0.D0)
25888 IF(IPRO.EQ.1) THEN
25889 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25890 ELSE IF(IPRO.EQ.2) THEN
25891 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25892 ELSE
25893 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25894 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25895 ENDIF
25896 DO 20 M=1,Max_pro_2
25897 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25898 20 CONTINUE
25899 30 CONTINUE
25900
25901C direct processes
25902 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25903 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25904 FAC = 0.D0
25905 SS = ECMH*ECMH
25906 ALPHAE = pho_alphae(SS)
25907 DO 300 I=1,NF
25908 IF(IDPDG1.EQ.22) THEN
25909* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25910 F1 = Q_ch2(I)*ALPHAE
25911 ELSE
25912 F1 = PARMDL(74)
25913 ENDIF
25914 IF(IDPDG2.EQ.22) THEN
25915* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25916 F2 = Q_ch2(I)*ALPHAE
25917 ELSE
25918 F2 = PARMDL(74)
25919 ENDIF
25920 FAC = FAC+F1*F2*3.D0
25921 300 CONTINUE
25922C direct cross sections
25923 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25924 T1 = -SS/2.D0*(1.D0+ZZ)
25925 T2 = -SS/2.D0*(1.D0-ZZ)
25926 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25927C hadronic part
25928 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25929
25930C leptonic part (e, mu, tau)
25931 DSIGMC(16) = 0.D0
25932 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25933 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25934C simulation of tau together with quarks
25935 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25936 ENDIF
25937 ENDIF
25938
25939 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25940 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
25941
25942 END
25943
25944*$ CREATE PHO_HARXTO.FOR
25945*COPY PHO_HARXTO
25946CDECK ID>, PHO_HARXTO
25947 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25948C**********************************************************************
25949C
25950C total hard cross section (perturbative QCD, Parton Model)
25951C
25952C input: ECMH CMS energy of scattering system
25953C PTCUTR PT cutoff for resolved processes
25954C PTCUTD PT cutoff for direct processes (photon, Pomeron)
25955C
25956C output: DSIGMC(0:MARPR2) cross sections for given cutoff
25957C DSDPTC(0:MARPR2) differential cross sections at cutoff
25958C
25959C note: COMPLEX*16 DSIGMC
25960C DOUBLE PRECISION DSDPTC
25961C
25962C**********************************************************************
25963 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25964 SAVE
25965
25966 PARAMETER ( Max_pro_2 = 16 )
25967 COMPLEX*16 DSIGMC
25968 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25969
25970C input/output channels
25971 INTEGER LI,LO
25972 COMMON /POINOU/ LI,LO
25973C model switches and parameters
25974 CHARACTER*8 MDLNA
25975 INTEGER ISWMDL,IPAMDL
25976 DOUBLE PRECISION PARMDL
25977 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25978C data of c.m. system of Pomeron / Reggeon exchange
25979 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25980 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25981 & SIDP,CODP,SIFP,COFP
25982 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25983 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25984 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25985C Reggeon phenomenology parameters
25986 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25987 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25988 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25989 & ALREG,ALREGP,GR(2),B0REG(2),
25990 & GPPP,GPPR,B0PPP,B0PPR,
25991 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25992C some constants
25993 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25994 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25995 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25996C integration precision for hard cross sections (obsolete)
25997 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25998 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25999C some hadron information, will be deleted in future versions
26000 INTEGER NFS
26001 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26002 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26003C hard scattering parameters used for most recent hard interaction
26004 INTEGER NFbeta,NF
26005 DOUBLE PRECISION ALQCD2,BQCD
26006 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26007
26008 double precision pho_alphae
26009
26010 COMPLEX*16 DSIG1
26011 DIMENSION DSIG1(0:Max_pro_2)
26012 DIMENSION ABSZ(32),WEIG(32)
26013
26014 DATA FAC / 3.0D0 /
26015
26016 DO 10 M=0,Max_pro_2
26017 DSIGMC(M)= CMPLX(0.D0,0.D0)
26018 10 CONTINUE
26019 EEC=ECMH/2.001D0
26020C
26021 IF ( PTCUTR.GE.EEC ) GOTO 100
26022C
26023C integration for resolved processes
26024 PTMIN = PTCUTR
26025 PTMAX = MIN(FAC*PTMIN,EEC)
26026 NPOINT = NGAUP1
26027 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26028 DO 60 M=1,9
26029 DSDPTC(M) = DREAL(DSIG1(M))
26030 60 CONTINUE
26031 DSIGH = DREAL(DSIG1(9))
26032 PTMXX = 0.95D0*PTMAX
26033 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26034 DSIGL = DREAL(DSIG1(9))
26035 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26036 EX1 = 1.0D0-EX
26037 DO 50 K=1,2
26038 IF ( PTMIN.GE.PTMAX ) GOTO 40
26039 RL = PTMIN**EX1
26040 RU = PTMAX**EX1
26041 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26042 DO 30 I=1,NPOINT
26043 R = ABSZ(I)
26044 PT = R**(1.0D0/EX1)
26045 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26046 F = WEIG(I)*PT/(R*EX1)
26047 DO 20 M=1,9
26048 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26049 20 CONTINUE
26050 30 CONTINUE
26051 40 PTMIN = PTMAX
26052 PTMAX = EEC
26053 NPOINT = NGAUP2
26054 50 CONTINUE
26055 100 CONTINUE
26056 DSIGMC(0) = DSIGMC(9)
26057 DSDPTC(0) = DSDPTC(9)
26058C
26059C integration for direct processes
26060 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26061C
26062 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26063 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26064 PTMIN = PTCUTD
26065 PTMAX = MIN(FAC*PTMIN,EEC)
26066 NPOINT = NGAUP1
26067 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26068 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26069 DO 160 M=10,16
26070 DSDPTC(M) = DREAL(DSIG1(M))
26071 160 CONTINUE
26072 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26073 PTMXX = 0.95D0*PTMAX
26074 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26075 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26076 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26077 EX1 = 1.0D0-EX
26078 DO 150 K=1,2
26079 IF ( PTMIN.GE.PTMAX ) GOTO 140
26080 RL = PTMIN**EX1
26081 RU = PTMAX**EX1
26082 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26083 DO 130 I=1,NPOINT
26084 R = ABSZ(I)
26085 PT = R**(1.0D0/EX1)
26086 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26087 F = WEIG(I)*PT/(R*EX1)
26088 DO 120 M=10,15
26089 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26090 120 CONTINUE
26091 130 CONTINUE
26092 140 PTMIN = PTMAX
26093 PTMAX = EEC
26094 NPOINT = NGAUP2
26095 150 CONTINUE
26096 ENDIF
26097C
26098 170 CONTINUE
26099C
26100C double direct process
26101 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26102 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26103 FACC = 0.D0
26104 SS = ECMH*ECMH
26105 ALPHAE = pho_alphae(SS)
26106 DO 300 I=1,NF
26107 IF(IDPDG1.EQ.22) THEN
26108* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26109 F1 = Q_ch2(I)*ALPHAE
26110 ELSE
26111 F1 = PARMDL(74)
26112 ENDIF
26113 IF(IDPDG2.EQ.22) THEN
26114* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26115 F2 = Q_ch2(I)*ALPHAE
26116 ELSE
26117 F2 = PARMDL(74)
26118 ENDIF
26119 FACC = FACC + F1*F2*3.D0
26120 300 CONTINUE
26121
26122 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26123 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26124C hadronic cross section
26125 DSIGMC(14) = R*FACC*AKFAC
26126C leptonic cross section
26127 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26128 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26129C simulation of tau together with quarks
26130 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26131 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26132 ELSE
26133 DSIGMC(16) = CMPLX(0.D0,0.D0)
26134 ENDIF
26135C sum of direct part
26136 DSIGMC(15) = CMPLX(0.D0,0.D0)
26137 DO 400 I=10,14
26138 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26139 400 CONTINUE
26140 ENDIF
26141C total sum (hadronic)
26142 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26143 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26144
26145 END
26146
26147*$ CREATE PHO_HARISR.FOR
26148*COPY PHO_HARISR
26149CDECK ID>, PHO_HARISR
26150 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26151 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26152C********************************************************************
26153C
26154C initial state radiation according to DGLAP evolution equations
26155C (backward evolution, no spin effects)
26156C
26157C input: IHPOM index of hard Pomeron
26158C negative: delete all previous entries
26159C P1,P2 4 momenta of hard scattered final partons
26160C (in CMS of hard scattering)
26161C IPF1,2 flavours of final partons
26162C IPA1,2 flavours of initial partons
26163C IV1,2 valence quark labels (0/1)
26164C Q2H momentum transfer (squared, positive)
26165C XH1,XH2 x values of initial partons
26166C XHMAX1,2 max. x values allowed
26167C
26168C output: all emitted partons in /POPISR/, final state
26169C partons are the first two entries
26170C shower evolution traced in /PODGL1/
26171C IPB1,2 flavours of new initial partons
26172C XISR1,2 x values of new initial partons
26173C IVO1,2 valence quark labels (0/1)
26174C
26175C attention: quark numbering according to PDG convention,
26176C but 0 for gluons
26177C
26178C********************************************************************
26179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26180 SAVE
26181
26182 PARAMETER (RHOMAS = 0.766D0,
26183 & DEPS = 1.D-10,
26184 & TINY = 1.D-10)
26185
26186 DIMENSION P1(4),P2(4)
26187
26188C input/output channels
26189 INTEGER LI,LO
26190 COMMON /POINOU/ LI,LO
26191C event debugging information
26192 INTEGER NMAXD
26193 PARAMETER (NMAXD=100)
26194 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26195 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26196 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26197 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26198C internal rejection counters
26199 INTEGER NMXJ
26200 PARAMETER (NMXJ=60)
26201 CHARACTER*10 REJTIT
26202 INTEGER IFAIL
26203 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26204C model switches and parameters
26205 CHARACTER*8 MDLNA
26206 INTEGER ISWMDL,IPAMDL
26207 DOUBLE PRECISION PARMDL
26208 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26209C data of c.m. system of Pomeron / Reggeon exchange
26210 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26211 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26212 & SIDP,CODP,SIFP,COFP
26213 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26214 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26215 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26216C some hadron information, will be deleted in future versions
26217 INTEGER NFS
26218 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26219 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26220C currently activated parton density parametrizations
26221 CHARACTER*8 PDFNAM
26222 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26223 DOUBLE PRECISION PDFLAM,PDFQ2M
26224 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26225 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26226C scale parameters for parton model calculations
26227 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26228 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26229 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26230 & NQQAL,NQQALI,NQQALF,NQQPD
26231C parameters for DGLAP backward evolution in ISR
26232 INTEGER NFSISR
26233 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26234 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26235C initial state parton radiation (internal part)
26236 INTEGER MXISR3,MXISR4
26237 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26238 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26239 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26240 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26241 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26242 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26243 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26244C some constants
26245 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26246 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26247 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26248C particles created by initial state evolution
26249 INTEGER MXISR1,MXISR2
26250 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26251 INTEGER IFLISR,IPOISR,IMXISR
26252 DOUBLE PRECISION PHISR
26253 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26254 & IPOISR(2,2,MXISR2),IMXISR(2)
26255
26256 DOUBLE PRECISION PYP,EER,THER,QMAXR
26257 INTEGER PYK
26258
26259 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26260 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26261 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26262
26263 IREJ = 0
26264 NTRY = 1000
26265 NITER = 0
26266C debug output
26267 IF(IDEB(79).GE.10) THEN
26268 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26269 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26270 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26271 ENDIF
26272 IF(IHPOM.EQ.0) RETURN
26273C
26274 10 CONTINUE
26275 NACC = 0
26276 IDMO(1) = IDPDG1
26277 IDMO(2) = IDPDG2
26278C
26279C copy final state partons to local fields
26280 IHIDX = ABS(IHPOM)
26281 IF(IHIDX.GT.MXISR2) THEN
26282 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26283 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26284 & IHIDX,MXISR2
26285 IREJ = 1
26286 ENDIF
26287 DO 50 K=1,2
26288 IF(IHPOM.LT.0) IMXISR(K) = 0
26289 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26290 IPAL(K) = IPOISR(K,1,IHIDX)
26291 50 CONTINUE
26292 DO 55 I=1,4
26293 PHISR(1,I,IPAL(1)) = P1(I)
26294 PHISR(2,I,IPAL(2)) = P2(I)
26295 55 CONTINUE
26296 IFLISR(1,IPAL(1)) = IPF1
26297 IFLISR(2,IPAL(2)) = IPF2
26298C
26299C check limitations, initialize /PODGL1/
26300 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26301 NEXT(1) = 1
26302 Q2SH(1,1) = Q2H
26303 ELSE
26304 NEXT(1) = 0
26305 Q2SH(1,1) = 0.D0
26306 ENDIF
26307 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26308 NEXT(2) = 1
26309 Q2SH(2,1) = Q2H
26310 ELSE
26311 NEXT(2) = 0
26312 Q2SH(2,1) = 0.D0
26313 ENDIF
26314C
26315 ISH(1) = 1
26316 ISH(2) = 1
26317 XPSH(1,1) = XH1
26318 XPSH(2,1) = XH2
26319C
26320 IFL1(1,1) = IPA1
26321 IVAL(1) = IV1
26322 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26323 IFL1(2,1) = IPA2
26324 IVAL(2) = IV2
26325 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26326C
26327 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26328 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26329 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26330C
26331C initialize parton shower loop
26332 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26333 AL2ISR(1) = PDFLAM(1)
26334 AL2ISR(2) = PDFLAM(2)
26335 XHMA(1) = XHMAX1
26336 XHMA(2) = XHMAX2
26337 XHMI(1) = PMISR(1)/PCMP
26338 XHMI(2) = PMISR(2)/PCMP
26339 ZPSH(1,1) = 1.D0
26340 ZPSH(2,1) = 1.D0
26341 SHAT1 = XH1*XH2*ECMP**2
26342 IF(IPAMDL(109).EQ.1) THEN
26343 PT2SH(1,1) = Q2H
26344 ELSE
26345 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26346 ENDIF
26347 PT2SH(2,1) = PT2SH(1,1)
26348 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26349 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26350 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26351 THSH(2,1) = THSH(1,1)
26352 IFANO(1) = 0
26353 IFANO(2) = 0
26354 ZZ = 1.D0
26355 IF(IREJ.NE.0) GOTO 800
26356C
26357C main generation loop
26358C -------------------------------------------------
26359 100 CONTINUE
26360C choose parton side to become solved
26361 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26362 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26363 IP = 1
26364 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26365 IP = 2
26366 ELSE
26367 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26368 ENDIF
26369 ELSE IF(NEXT(1).EQ.1) THEN
26370 IP = 1
26371 ELSE IF(NEXT(2).EQ.1) THEN
26372 IP = 2
26373 ELSE
26374 GOTO 800
26375 ENDIF
26376 INDX = ISH(IP)
26377C INDX now parton position of parton to become solved
26378C IP now side to be treated
26379 XP = XPSH(IP,INDX)
26380 Q2P = Q2SH(IP,INDX)
26381 PT2 = PT2SH(IP,INDX)
26382 IFLB = IFL1(IP,INDX)
26383C check available x
26384 XMIP = XHMI(IP)
26385C cutoff by x limitation: no further development
26386 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26387 NEXT(IP) = 0
26388 Q2SH(IP,INDX) = 0.D0
26389 IF(IDEB(79).GE.17) THEN
26390 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26391 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26392 & XP,XMIP,XHMA(IP),IP,INDX
26393 ENDIF
26394 GOTO 100
26395 ENDIF
26396C initial value of evolution variable t
26397 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26398 DO 110 I=-NFSISR,NFSISR
26399 WGGAP(I) = 0.D0
26400 WGPDF(I) = 0.D0
26401 110 CONTINUE
26402C DGLAP weights
26403 ZMIN = XP/XHMA(IP)
26404 ZMAX = XP/(XP+XMIP)
26405 CF = 4./3.
26406C q --> q g, g --> g g
26407 IF(IFLB.EQ.0) THEN
26408 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26409 & +2.D0*LOG(ZMAX/ZMIN))
26410 DO 120 I=1,NFSISR
26411 WGGAP(I) = WGGAP(0)
26412 WGGAP(-I) = WGGAP(0)
26413 120 CONTINUE
26414 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26415 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26416C q --> g q, g --> q qb
26417 ELSE IF(ABS(IFLB).LE.6) THEN
26418 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26419 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26420 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26421 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26422 ELSE
26423 WRITE(LO,'(/1X,A,I7)')
26424 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26425 CALL PHO_ABORT
26426 ENDIF
26427C anomalous/resolved evolution
26428 IPDFC = 0
26429 IF(IPAMDL(110).GE.1) THEN
26430 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26431 & .AND.(IFLB.NE.21)) THEN
26432 WGDIR = 0.D0
26433 IF(NQQALI.EQ.1) THEN
26434 SCALE2 = PT2*AQQPD
26435 ELSE
26436 SCALE2 = Q2P*AQQPD
26437 ENDIF
26438 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26439 IPDFC = 1
26440 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26441 XI = DT_RNDM(XP)*PD1(IFLB)
26442 IF(WGDIR.GT.XI) THEN
26443C debug output
26444 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26445 & 'PHO_HARISR: ',
26446 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26447 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26448 Q2SH(IP,INDX) = 0.D0
26449 NEXT(IP) = 0
26450 IFANO(IP) = INDX
26451 GOTO 100
26452 ENDIF
26453 ENDIF
26454 ENDIF
26455C
26456C rejection loop for z,t sampling
26457C ------------------------------------
26458 200 CONTINUE
26459 NITER = NITER+1
26460 IF(NITER.GE.NTRY) THEN
26461 WRITE(LO,'(1X,A,2I6)')
26462 & 'PHO_HARISR: too many rejections',NITER,NTRY
26463 CALL PHO_PREVNT(-1)
26464C clean up event
26465 IREJ = 1
26466 GOTO 10
26467 ENDIF
26468C PDF weights
26469 IF(IPDFC.EQ.0) THEN
26470 IF(NQQALI.EQ.1) THEN
26471 SCALE2 = PT2*AQQPD
26472 ELSE
26473 SCALE2 = Q2P*AQQPD
26474 ENDIF
26475 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26476 ENDIF
26477 IPDFC = 0
26478C
26479 WGTOT = 0.D0
26480 DO 210 I=-NFSISR,NFSISR
26481 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26482 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26483 210 CONTINUE
26484C
26485 215 CONTINUE
26486C sample new t value
26487 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26488 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26489C debug output
26490 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26491 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26492C compare to limits
26493 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26494 Q2SH(IP,INDX) = 0.D0
26495 NEXT(IP) = 0
26496 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26497 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26498 & Q2NEW,Q2MISR(IP),IP,INDX
26499 GOTO 100
26500 ENDIF
26501 Q2SH(IP,INDX) = Q2NEW
26502 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26503C selection of flavours
26504 XI = WGTOT*DT_RNDM(TT)
26505 IFLA = -NFSISR-1
26506 220 CONTINUE
26507 IFLA = IFLA+1
26508 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26509 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26510C debug output
26511 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26512 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26513C selection of z
26514 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26515C debug output
26516 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26517 & 'PHO_HARISR: pre-selected ZZ',ZZ
26518C angular ordering
26519 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26520 IF(THETA.GT.THSH(IP,INDX)) THEN
26521 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26522 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26523 & THETA,THSH(IP,INDX)
26524 GOTO 215
26525 ENDIF
26526C rejection weight given by new PDFs
26527 XNEW = XP/ZZ
26528 PT2NEW = Q2NEW*(1.D0-ZZ)
26529 IF(NQQALI.EQ.1) THEN
26530 SCALE2 = PT2NEW*AQQPD
26531 ELSE
26532 SCALE2 = Q2NEW*AQQPD
26533 ENDIF
26534 IF(SCALE2.LT.Q2MISR(IP)) THEN
26535 Q2SH(IP,INDX) = 0.D0
26536 NEXT(IP) = 0
26537 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26538 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26539 & Q2NEW,Q2MISR(IP),IP,INDX
26540 GOTO 100
26541 ENDIF
26542 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26543 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26544 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26545 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26546 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26547 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26548 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26549 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26550 WRITE(LO,'(1X,A,E12.3)')
26551 & 'PHO_HARISR: final weight:',WGF
26552 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26553 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26554 ENDIF
26555 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26556
26557 IF(IDEB(79).GE.15) THEN
26558 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26559 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26560 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26561 ENDIF
26562
26563 IF(INDX.GE.MXISR3) THEN
26564 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26565 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26566 IREJ = 1
26567 RETURN
26568 ENDIF
26569C branching accepted, registration
26570 Q2SH(IP,INDX) = Q2NEW
26571 PT2SH(IP,INDX) = PT2NEW
26572 ZPSH(IP,INDX) = ZZ
26573 IFL2(IP,INDX) = IFLA-IFLB
26574 Q2SH(IP,INDX+1) = Q2NEW
26575 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26576 XPSH(IP,INDX+1) = XNEW
26577 THSH(IP,INDX+1) = THETA
26578 IFL1(IP,INDX+1) = IFLA
26579 ISH(IP) = ISH(IP)+1
26580
26581 NACC = NACC+1
26582 IF(NACC.GT.MXISR4) THEN
26583 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26584 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26585 IREJ = 1
26586 RETURN
26587 ENDIF
26588 SHAT(NACC) = SHAT1
26589 IBRA(1,NACC) = IP
26590 IBRA(2,NACC) = INDX
26591 SHAT1 = SHAT1/ZZ
26592
26593C generation of next branching
26594 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26595
26596 800 CONTINUE
26597
26598C new initial flavours, x values
26599 IPB1 = IFL1(1,ISH(1))
26600 IPB2 = IFL1(2,ISH(2))
26601 XISR1 = XPSH(1,ISH(1))
26602 XISR2 = XPSH(2,ISH(2))
26603 IVO1 = IVAL(1)
26604 IVO2 = IVAL(2)
26605C valence flavours
26606 IF(IPB1.NE.0) THEN
26607 IF(ISH(1).GT.1) THEN
26608 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26609 IF(IDPDG1.EQ.22) THEN
26610 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26611 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26612 ELSE
26613 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26614 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26615 ENDIF
26616 ENDIF
26617 ENDIF
26618 IF(IPB2.NE.0) THEN
26619 IF(ISH(2).GT.1) THEN
26620 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26621 IF(IDPDG2.EQ.22) THEN
26622 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26623 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26624 ELSE
26625 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26626 ENDIF
26627 ENDIF
26628 ENDIF
26629
26630C parton kinematics
26631 IF(NACC.GT.0) THEN
26632C final partons in CMS
26633 PM(3) = (XH1-XH2)*ECMP/2.D0
26634 PM(4) = (XH1+XH2)*ECMP/2.D0
26635 SH = XH1*XH2*ECMP**2
26636 SSH = SQRT(SH)
26637 GB(3) = PM(3)/SSH
26638 GB(4) = PM(4)/SSH
26639 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26640 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26641 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26642 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26643 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26644 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26645 IL(1) = 1
26646 IL(2) = 1
26647 DO 900 I=1,NACC
26648 IPA = IBRA(1,I)
26649 IPB = 3-IPA
26650 IL(IPA) = IBRA(2,I)
26651C new initial partons in CMS
26652 SH = SHAT(I)
26653 SSH = SQRT(SH)
26654 SHZ = SH/ZPSH(IPA,IL(IPA))
26655 SSHZ = SQRT(SHZ)
26656 Q2(1) = Q2SH(1,IL(1))
26657 Q2(2) = Q2SH(2,IL(2))
26658 PC(1,1) = 0.D0
26659 PC(1,2) = 0.D0
26660 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26661 & /(2.D0*SSH)
26662 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26663 PC(2,1) = 0.D0
26664 PC(2,2) = 0.D0
26665 PC(2,3) = -PC(1,3)
26666 PC(2,4) = SSH-PC(1,4)
26667 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26668 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26669 S1 = SH+Q2(IPA)+Q2(IPB)
26670 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26671 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26672 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26673 IF(Q2(IPB).LT.0.1D0) THEN
26674 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26675 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26676 ELSE
26677 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26678 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26679 ENDIF
26680 NGEN = 1
26681C max. virtuality for time-like showers
26682 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26683 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26684C generate time-like parton shower
26685 KF = IFL2(IPA,IL(IPA))
26686 IF(KF.EQ.0) KF = 21
26687 EER = MIN(EE3-PC(IPA,4),ECMP)
26688 THER = 0.
26689 CALL PY1ENT(1,KF,EER,THER,THER)
26690 QMAXR = SQRT(QMAX)
26691 CALL PYSHOW(1,0,QMAXR)
26692C debug output
26693 IF(IDEB(79).GE.25) THEN
26694 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26695 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26696 & EER,QMAX,XMS4M,Q2(IPA)
26697 CALL PYLIST(1)
26698 ENDIF
26699 NGEN = PYK(0,1)
26700 IF(NGEN.GT.1) THEN
26701 PJX = 0.D0
26702 PJY = 0.D0
26703 PJZ = 0.D0
26704 PJE = 0.D0
26705 KK = IPAL(IPA)
26706 DO 820 K=3,NGEN
26707 IF(PYK(K,1).LE.4) THEN
26708 KK = KK+1
26709 IF(KK.GT.MXISR1) THEN
26710 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26711 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26712 IREJ = 1
26713 RETURN
26714 ENDIF
26715 PHISR(IPA,1,KK) = PYP(K,1)
26716 PJX = PJX+PHISR(IPA,1,KK)
26717 PHISR(IPA,2,KK) = PYP(K,2)
26718 PJY = PJY+PHISR(IPA,2,KK)
26719 PHISR(IPA,3,KK) = PYP(K,3)
26720 PJZ = PJZ+PHISR(IPA,3,KK)
26721 PHISR(IPA,4,KK) = PYP(K,4)
26722 PJE = PJE+PHISR(IPA,4,KK)
26723 IFLISR(IPA,KK) = PYK(K,2)
26724 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26725 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26726 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26727 ENDIF
26728 820 CONTINUE
26729 NGEN = KK-IPAL(IPA)
26730 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26731 PP4 = SQRT(PJE**2-XMS4)
26732 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26733C debug output
26734 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26735 & 'PHO_HARISR: ',
26736 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26737 & PJE,PJX,PJY,PJZ,PP4,XMS4
26738 ENDIF
26739 ENDIF
26740 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26741 & /(2.D0*PC(IPA,3))
26742 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26743 IF(PT3.LT.0.D0) THEN
26744 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26745 & 'PHO_HARISR: rejection due to PT3',PT3
26746 GOTO 10
26747 ENDIF
26748 PT3 = SQRT(PT3)
26749 CALL PHO_SFECFE(SFE,CFE)
26750 PX3 = CFE*PT3
26751 PY3 = SFE*PT3
26752C
26753 IF(NGEN.GT.1) THEN
26754C time-like shower generated
26755 EE4 = EE3-PC(IPA,4)
26756 PZ4 = PZ3-PC(IPA,3)
26757 PP4 = SQRT(PT3**2+PZ4**2)
26758C Lorentz boost
26759 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26760 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26761C rotation angles
26762 CODD = PZ4/PP4
26763 SIDD = SQRT(PX3**2+PY3**2)/PP4
26764 COFD = 1.D0
26765 SIFD = 0.D0
26766 IF(PP4*SIDD.GT.1.D-5) THEN
26767 COFD = PX3/(SIDD*PP4)
26768 SIFD = PY3/(SIDD*PP4)
26769 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26770 COFD = COFD/ANORF
26771 SIFD = SIFD/ANORF
26772 ENDIF
26773C copy partons back
26774 KK = IPAL(IPA)
26775 DO 830 K=1,NGEN
26776 KK = KK+1
26777 PX = PHISR(IPA,1,KK)
26778 PY = PHISR(IPA,2,KK)
26779 PZ = PHISR(IPA,3,KK)
26780 COH= PHISR(IPA,4,KK)
26781 EE = GAM*COH+BEG*PZ
26782 PZ = GAM*PZ +BEG*COH
26783 PHISR(IPA,4,KK) = EE
26784 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26785 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26786 830 CONTINUE
26787 IPAL(IPA) = KK
26788 ELSE
26789C no time-like shower generated
26790 IPAL(IPA) = IPAL(IPA)+1
26791 PHISR(IPA,1,IPAL(IPA)) = PX3
26792 PHISR(IPA,2,IPAL(IPA)) = PY3
26793 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26794 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26795 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
26796 ENDIF
26797 PC(IPA,1) = PX3
26798 PC(IPA,2) = PY3
26799 PC(IPA,3) = PZ3
26800 PC(IPA,4) = EE3
26801C boost / rotate into new CMS
26802 DO 842 K=1,4
26803 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26804 842 CONTINUE
26805 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26806 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26807 COG= PM(3)/PTOT1
26808 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26809 COH=1.D0
26810 SIH=0.D0
26811 IF(PTOT1*SIG.GT.1.D-5) THEN
26812 COH=PM(1)/(SIG*PTOT1)
26813 SIH=PM(2)/(SIG*PTOT1)
26814 ANORF=SQRT(COH*COH+SIH*SIH)
26815 COH=COH/ANORF
26816 SIH=SIH/ANORF
26817 ENDIF
26818 DO 845 K=1,2
26819 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26820 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26821 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26822 & PTOT1,PM(1),PM(2),PM(3),PM(4))
26823 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26824 & PN(2),PN(3))
26825 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26826 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26827 PHISR(K,4,L) = PM(4)
26828 844 CONTINUE
26829 845 CONTINUE
26830 900 CONTINUE
26831C boost back to global CMS
26832 PM(3) = (XISR1-XISR2)/2.D0
26833 PM(4) = (XISR1+XISR2)/2.D0
26834 SSH = SQRT(XISR1*XISR2)
26835 GB(3) = PM(3)/SSH
26836 GB(4) = PM(4)/SSH
26837 DO 945 K=1,2
26838 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26839 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26840 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26841 & PM(2),PM(3),PM(4))
26842 PHISR(K,1,L) = PM(1)
26843 PHISR(K,2,L) = PM(2)
26844 PHISR(K,3,L) = PM(3)
26845 PHISR(K,4,L) = PM(4)
26846 944 CONTINUE
26847 945 CONTINUE
26848 ENDIF
26849 IPOISR(1,2,IHIDX) = IPAL(1)
26850 IPOISR(2,2,IHIDX) = IPAL(2)
26851 IMXISR(1) = IPAL(1)
26852 IMXISR(2) = IPAL(2)
26853C
26854C debug output
26855 IF(IDEB(79).GE.10) THEN
26856 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26857 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26858 IF(NACC.GT.0) THEN
26859 WRITE(LO,'(1X,A,2I5,/6X,A)')
26860 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26861 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
26862 DO 600 II=1,NACC
26863 K = IBRA(1,II)
26864 I = IBRA(2,II)
26865 WRITE(LO,'(5X,4I5,4E11.3)')
26866 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26867 & ZPSH(K,I)
26868 600 CONTINUE
26869 ENDIF
26870C check of final configuration
26871 PX3 = 0.D0
26872 PY3 = 0.D0
26873 PZ3 = 0.D0
26874 EE3 = 0.D0
26875 IFSUM(1) = 0
26876 IFSUM(2) = 0
26877 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26878 DO 745 K=1,2
26879 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26880 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26881 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26882 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26883 PX3 = PX3 + PHISR(K,1,L)
26884 PY3 = PY3 + PHISR(K,2,L)
26885 PZ3 = PZ3 + PHISR(K,3,L)
26886 EE3 = EE3 + PHISR(K,4,L)
26887 744 CONTINUE
26888 745 CONTINUE
26889 IFSUM(1) = IFSUM(1)-IPB1
26890 IFSUM(2) = IFSUM(2)-IPB2
26891 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26892 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26893 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26894 & IFSUM,PX3,PY3,PZ3,EE3
26895 ENDIF
26896 END
26897
26898*$ CREATE PHO_HARZSP.FOR
26899*COPY PHO_HARZSP
26900CDECK ID>, PHO_HARZSP
26901 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26902C*********************************************************************
26903C
26904C sampling of z values from DGLAP kernels
26905C
26906C input: IFLA,IFLB parton flavours
26907C NFSH flavours involved in hard processes
26908C ZMIN minimal ZZ allowed
26909C ZMAX maximal ZZ allowed
26910C
26911C output: ZZ z value
26912C
26913C*********************************************************************
26914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26915 SAVE
26916
26917 PARAMETER ( DEPS = 1.D-10 )
26918
26919C input/output channels
26920 INTEGER LI,LO
26921 COMMON /POINOU/ LI,LO
26922C event debugging information
26923 INTEGER NMAXD
26924 PARAMETER (NMAXD=100)
26925 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26926 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26927 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26928 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26929C internal rejection counters
26930 INTEGER NMXJ
26931 PARAMETER (NMXJ=60)
26932 CHARACTER*10 REJTIT
26933 INTEGER IFAIL
26934 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26935
26936 IF(ZMAX.LE.ZMIN) THEN
26937 WRITE(LO,'(1X,A,2E12.3)')
26938 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26939 CALL PHO_PREVNT(-1)
26940 ZZ = 0.D0
26941 RETURN
26942 ENDIF
26943C
26944 IF(IFLB.EQ.0) THEN
26945 IF(IFLA.EQ.0) THEN
26946C g --> g g
26947 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26948 C2 = (1.D0-ZMIN)/ZMIN
26949 100 CONTINUE
26950 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26951 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26952 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26953C q --> q g
26954 C1 = ZMAX/ZMIN
26955 200 CONTINUE
26956 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26957 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26958 ELSE
26959 GOTO 900
26960 ENDIF
26961 ELSE IF(ABS(IFLB).LE.NFSH) THEN
26962 IF(IFLA.EQ.0) THEN
26963C g --> q qb
26964 C1 = ZMAX-ZMIN
26965 300 CONTINUE
26966 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26967 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26968 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26969C q --> g q
26970 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26971 C2 = 1.D0-ZMIN
26972 400 CONTINUE
26973 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26974 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
26975 ELSE
26976 GOTO 900
26977 ENDIF
26978 ELSE
26979 GOTO 900
26980 ENDIF
26981C debug output
26982 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
26983 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
26984 & IFLA,IFLB,ZZ,ZMIN,ZMAX
26985 RETURN
26986
26987 900 CONTINUE
26988 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
26989 & IFLA,IFLB
26990 CALL PHO_ABORT
26991
26992 END
26993
26994*$ CREATE PHO_ALPHAE.FOR
26995*COPY PHO_ALPHAE
26996CDECK ID>, PHO_ALPHAE
26997 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
26998C**********************************************************************
26999C
27000C calculation of ALPHA_em
27001C
27002C input: Q2 scale in GeV**2
27003C
27004C**********************************************************************
27005 IMPLICIT NONE
27006 SAVE
27007
27008 DOUBLE PRECISION Q2
27009
27010C input/output channels
27011 INTEGER LI,LO
27012 COMMON /POINOU/ LI,LO
27013C model switches and parameters
27014 CHARACTER*8 MDLNA
27015 INTEGER ISWMDL,IPAMDL
27016 DOUBLE PRECISION PARMDL
27017 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27018
27019 DOUBLE PRECISION PYALEM
27020
27021 pho_alphae = 1.D0/137.D0
27022
27023 if(ipamdl(120).eq.1) then
27024 pho_alphae = PYALEM(Q2)
27025 endif
27026
27027 END
27028
27029*$ CREATE PHO_ALPHAS.FOR
27030*COPY PHO_ALPHAS
27031CDECK ID>, PHO_ALPHAS
27032 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27033C**********************************************************************
27034C
27035C calculation of ALPHA_S
27036C
27037C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27038C 2 lambda_QCD**2 for PDF 2 evolution
27039C 3 lambda_QCD**2 for hard scattering
27040C Q2 scale in GeV**2
27041C
27042C initialization needed:
27043C IMODE = 0 lambda values taken from PDF table
27044C -1 given Q2 is 4-flavour lambda 1
27045C -2 given Q2 is 4-flavour lambda 2
27046C -3 given Q2 is 4-flavour lambda 3
27047C
27048C
27049C**********************************************************************
27050 IMPLICIT NONE
27051 SAVE
27052
27053 DOUBLE PRECISION Q2
27054 INTEGER IMODE
27055
27056C input/output channels
27057 INTEGER LI,LO
27058 COMMON /POINOU/ LI,LO
27059C model switches and parameters
27060 CHARACTER*8 MDLNA
27061 INTEGER ISWMDL,IPAMDL
27062 DOUBLE PRECISION PARMDL
27063 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27064C hard scattering parameters used for most recent hard interaction
27065 INTEGER NFbeta,NF
27066 DOUBLE PRECISION ALQCD2,BQCD
27067 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27068C currently activated parton density parametrizations
27069 CHARACTER*8 PDFNAM
27070 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27071 DOUBLE PRECISION PDFLAM,PDFQ2M
27072 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27073 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27074
27075 INTEGER I
27076
27077 PHO_ALPHAS = 0.D0
27078
27079 IF(IMODE.GT.0) THEN
27080
27081 IF(Q2.LT.PARMDL(148)) THEN
27082 NFbeta = 1
27083 ELSE IF(Q2.LT.PARMDL(149)) THEN
27084 NFbeta = 2
27085 ELSE IF(Q2.LT.PARMDL(150)) THEN
27086 NFbeta = 3
27087 ELSE
27088 NFbeta = 4
27089 ENDIF
27090
27091 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27092 NFbeta = NFbeta+2
27093
27094 ELSE IF(IMODE.EQ.0) THEN
27095
27096 DO I=1,3
27097 if(I.EQ.3) then
27098 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27099 else
27100 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27101 endif
27102 ALQCD2(I,1) = PARMDL(148)
27103 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27104 ALQCD2(I,3) = PARMDL(149)
27105 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27106 ALQCD2(I,4) = PARMDL(150)
27107 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27108
27109 ENDDO
27110
27111 ELSE IF(IMODE.LT.0) THEN
27112
27113 if(IMODE.eq.-4) then
27114 I = 3
27115 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27116 else
27117 I = -IMODE
27118 ALQCD2(I,2) = Q2
27119 endif
27120 ALQCD2(I,1) = PARMDL(148)
27121 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27122 ALQCD2(I,3) = PARMDL(149)
27123 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27124 ALQCD2(I,4) = PARMDL(150)
27125 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27126
27127 ENDIF
27128
27129 END
27130
27131*$ CREATE PHO_DFWRAP.FOR
27132*COPY PHO_DFWRAP
27133CDECK ID>, PHO_DFWRAP
27134 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27135C**********************************************************************
27136C
27137C wrapper for diffraction dissociation in hadron-nucleus and
27138C nucleus-nucleus collisions with DPMJET
27139C
27140C input: MODE 1: transformation into CMS
27141C 2: transformation into Lab
27142C JM1/2 indices of old mother particles
27143C JM1/2N indices of new mother particles
27144C
27145C**********************************************************************
27146 IMPLICIT NONE
27147 SAVE
27148
27149 INTEGER MODE,JM1,JM2
27150
27151C input/output channels
27152 INTEGER LI,LO
27153 COMMON /POINOU/ LI,LO
27154C event debugging information
27155 INTEGER NMAXD
27156 PARAMETER (NMAXD=100)
27157 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27158 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27159 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27160 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27161C standard particle data interface
27162 INTEGER NMXHEP
27163 PARAMETER (NMXHEP=4000)
27164 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27165 DOUBLE PRECISION PHEP,VHEP
27166 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27167 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27168 & VHEP(4,NMXHEP)
27169C extension to standard particle data interface (PHOJET specific)
27170 INTEGER IMPART,IPHIST,ICOLOR
27171 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27172C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27173 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27174 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27175 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27176 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27177
27178 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27179 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27180
27181 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27182
27183C transformation into CMS
27184
27185 IF(MODE.EQ.1) THEN
27186
27187 JM1S = JM1
27188 JM2S = JM2
27189 NHEPS = NHEP
27190
27191 XM1 = PHEP(5,JM1)
27192 XM2 = PHEP(5,JM2)
27193
27194C boost into CMS
27195 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27196 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27197 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27198 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27199 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27200 ECMD = SQRT(SS)
27201 DO 10 I=1,4
27202 GAMBED(I) = P1(I)/ECMD
27203 10 CONTINUE
27204 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27205 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27206 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27207C rotation angles
27208 CODD = P1(3)/PTOT1
27209 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27210 COFD = 1.D0
27211 SIFD = 0.D0
27212 IF(PTOT1*SIDD.GT.1.D-5) THEN
27213 COFD = P1(1)/(SIDD*PTOT1)
27214 SIFD = P1(2)/(SIDD*PTOT1)
27215 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27216 COFD = COFD/ANORF
27217 SIFD = SIFD/ANORF
27218 ENDIF
27219
27220C initial particles in CMS
27221
27222 P1(1) = 0.D0
27223 P1(2) = 0.D0
27224 P1(3) = ECMD/2.D0*XPSUB
27225 P1(4) = P1(3)
27226
27227 P2(1) = 0.D0
27228 P2(2) = 0.D0
27229 P2(3) = -ECMD/2.D0*XTSUB
27230 P2(4) = -P2(3)
27231
27232 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27233
27234 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27235 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27236 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27237
27238 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27239 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27240 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27241
27242 JM1 = JM1N
27243 JM2 = JM2N
27244
27245C transformation into lab.
27246
27247 ELSE IF(MODE.EQ.2) THEN
27248
27249 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27250 & GAMBED(1),GAMBED(2),GAMBED(3))
27251
27252 JM1 = JM1S
27253 JM2 = JM2S
27254
27255C clean up after rejection
27256
27257 ELSE IF(MODE.EQ.-2) THEN
27258
27259 NHEP = NHEPS
27260
27261 JM1 = JM1S
27262 JM2 = JM2S
27263
27264 ELSE
27265
27266 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27267
27268 ENDIF
27269
27270 END
27271
27272*$ CREATE PHO_DIFDIS.FOR
27273*COPY PHO_DIFDIS
27274CDECK ID>, PHO_DIFDIS
27275 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27276 & MSOFT,MHARD,IREJ)
27277C***********************************************************************
27278C
27279C sampling of diffractive events of different kinds,
27280C (produced particles stored in /POEVT1/)
27281C
27282C input: IDIF1/2 diffractive process particle 1/2
27283C 0 elastic/quasi-elastic scattering
27284C 1 diffraction dissociation
27285C IMOTH1/2 index of mother particles in /POEVT1/
27286C SPROB suppression factor (survival probability) for
27287C resolved diffraction dissociation
27288C IMODE mode of operation
27289C 0 sampling of diffractive cut
27290C 1 sampling of enhanced cut
27291C 2 sampling of diffractive cut without
27292C scattering (needed for double-pomeron)
27293C -1 initialization
27294C -2 output of statistics
27295C
27296C output: MSOFT number of generated soft strings
27297C MHARD number of generated hard strings
27298C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27299C 0 quasi elastic scattering
27300C 1 low-mass diffractive dissociation
27301C 2 soft high-mass diffractive dissociation
27302C 3 hard resolved diffractive dissociation
27303C 4 hard direct diffractive dissociation
27304C IREJ rejection label
27305C 0 successful generation of partons
27306C 1 failure
27307C
27308C***********************************************************************
27309 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27310 SAVE
27311
27312 PARAMETER ( EPS = 1.D-7,
27313 & DEPS = 1.D-10)
27314
27315C input/output channels
27316 INTEGER LI,LO
27317 COMMON /POINOU/ LI,LO
27318C event debugging information
27319 INTEGER NMAXD
27320 PARAMETER (NMAXD=100)
27321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27325C general process information
27326 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27327 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27328C internal rejection counters
27329 INTEGER NMXJ
27330 PARAMETER (NMXJ=60)
27331 CHARACTER*10 REJTIT
27332 INTEGER IFAIL
27333 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27334C global event kinematics and particle IDs
27335 INTEGER IFPAP,IFPAB
27336 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27337 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27338C c.m. kinematics of diffraction
27339 INTEGER NPOSD
27340 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27341 & SIDD,CODD,SIFD,COFD,PDCMS
27342 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27343 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27344C obsolete cut-off information
27345 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27346 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27347C some constants
27348 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27349 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27350 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27351C model switches and parameters
27352 CHARACTER*8 MDLNA
27353 INTEGER ISWMDL,IPAMDL
27354 DOUBLE PRECISION PARMDL
27355 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27356C Reggeon phenomenology parameters
27357 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27358 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27359 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27360 & ALREG,ALREGP,GR(2),B0REG(2),
27361 & GPPP,GPPR,B0PPP,B0PPR,
27362 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27363C parameters of 2x2 channel model
27364 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27365 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27366C table of particle indices for recursive PHOJET calls
27367 INTEGER MAXIPX
27368 PARAMETER ( MAXIPX = 100 )
27369 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27370 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27371 & IPOIX1,IPOIX2,IPOIX3
27372C standard particle data interface
27373 INTEGER NMXHEP
27374 PARAMETER (NMXHEP=4000)
27375 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27376 DOUBLE PRECISION PHEP,VHEP
27377 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27378 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27379 & VHEP(4,NMXHEP)
27380C extension to standard particle data interface (PHOJET specific)
27381 INTEGER IMPART,IPHIST,ICOLOR
27382 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27383C event weights and generated cross section
27384 INTEGER IPOWGC,ISWCUT,IVWGHT
27385 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27386 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27387 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27388
27389 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27390 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27391 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27392 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27393 & IDIR(2),IPROC(2)
27394
27395 IF(IMODE.EQ.-1) THEN
27396C initialization
27397 RETURN
27398 ELSE IF(IMODE.EQ.-2) THEN
27399C output of statistics
27400 RETURN
27401 ENDIF
27402
27403 IREJ = 0
27404C mass cuts
27405 PIMASS = 0.140D0
27406C debug output
27407 IF(IDEB(45).GE.10) THEN
27408 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27409 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27410 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27411 ENDIF
27412 IPAR(1) = IDIF1
27413 IPAR(2) = IDIF2
27414C save current status
27415 MSOFT = 0
27416 MHARD = 0
27417 KHPOMS = KHPOM
27418 KSPOMS = KSPOM
27419 KSREGS = KSREG
27420 KHDIRS = KHDIR
27421 IPOIS1 = IPOIX1
27422 IPOIS2 = IPOIX2
27423 IPOIS3 = IPOIX3
27424 JDA11 = JDAHEP(1,IMOTH1)
27425 JDA21 = JDAHEP(2,IMOTH1)
27426 JDA12 = JDAHEP(1,IMOTH2)
27427 JDA22 = JDAHEP(2,IMOTH2)
27428 ISTH1 = ISTHEP(IMOTH1)
27429 ISTH2 = ISTHEP(IMOTH2)
27430 NHEPS = NHEP
27431C get mother data
27432 NPOSD(1) = IMOTH1
27433 NPOSD(2) = IMOTH2
27434 DO 20 I=1,2
27435 IDPDG(I) = IDHEP(NPOSD(I))
27436 IDBAM(I) = IMPART(NPOSD(I))
27437 AMP(I) = PHO_PMASS(IDBAM(I),0)
27438 IF(IDPDG(I).EQ.22) THEN
27439 PMASSD(I) = 0.765D0
27440 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27441 ELSE
27442 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27443 PVIRTD(I) = 0.D0
27444 ENDIF
27445 20 CONTINUE
27446C get CM system
27447 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27448 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27449 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27450 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27451 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27452 ECMD = SQRT(SS)
27453 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27454 & 'PHO_DIFDIS: availabe energy',ECMD
27455C check total available energy
27456 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27457 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27458 & 'PHO_DIFDIS: ',
27459 & 'not enough energy for inelastic diffraction',
27460 & 'ECM, particle masses:',ECMD,AMP
27461 IFAIL(7) = IFAIL(7)+1
27462 IREJ = 1
27463 RETURN
27464 ENDIF
27465C boost into CMS
27466 DO 10 I=1,4
27467 GAMBED(I) = P1(I)/ECMD
27468 10 CONTINUE
27469 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27470 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27471 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27472C rotation angles
27473 CODD = P1(3)/PTOT1
27474 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27475 COFD = 1.D0
27476 SIFD = 0.D0
27477 IF(PTOT1*SIDD.GT.1.D-5) THEN
27478 COFD = P1(1)/(SIDD*PTOT1)
27479 SIFD = P1(2)/(SIDD*PTOT1)
27480 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27481 COFD = COFD/ANORF
27482 SIFD = SIFD/ANORF
27483 ENDIF
27484C initial particles in CMS
27485 PDCMS(1,1) = 0.D0
27486 PDCMS(2,1) = 0.D0
27487 PDCMS(3,1) = PTOT1
27488 PDCMS(4,1) = P1(4)
27489 PDCMS(1,2) = 0.D0
27490 PDCMS(2,2) = 0.D0
27491 PDCMS(3,2) = -PTOT1
27492 PDCMS(4,2) = ECMD-P1(4)
27493C get new CM momentum
27494 AM12 = PMASSD(1)**2
27495 AM22 = PMASSD(2)**2
27496 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27497
27498C coherence constraint (min/max diffractive mass allowed)
27499 IF(IMODE.EQ.2) THEN
27500 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27501 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27502 THRM2 = SQRT(1-PARMDL(72))*ECMD
27503 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27504 ELSE
27505 THRM1 = PARMDL(46)
27506 THRM2 = PARMDL(45)*ECMD
27507C check kinematic limits
27508 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27509 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27510 ENDIF
27511
27512C check energy vs. coherence constraints
27513 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27514 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27515
27516C no phase space available
27517 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27518 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27519 & 'PHO_DIFDIS: ',
27520 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27521 & 'side 1: min. mass, upper mass limit:',
27522 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27523 & 'side 2: min. mass, upper mass limit:',
27524 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27525 IFAIL(7) = IFAIL(7)+1
27526 IREJ = 1
27527 RETURN
27528 ENDIF
27529
27530 ITRY = 0
27531 ITRYM = 10
27532 IPARS1 = IPAR(1)
27533 IPARS2 = IPAR(2)
27534
27535C main rejection loop
27536C -------------------------------
27537 50 CONTINUE
27538 ITRY = ITRY+1
27539 IF(ITRY.GT.1) THEN
27540 IFAIL(13) = IFAIL(13)+1
27541 IF(ITRY.GE.ITRYM) THEN
27542 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27543 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27544 IFAIL(7) = IFAIL(7)+1
27545 IREJ = 1
27546 RETURN
27547 ENDIF
27548 ENDIF
27549 KSPOM = KSPOMS
27550 KHPOM = KHPOMS
27551 KHDIR = KHDIRS
27552 KSREG = KSREGS
27553 IPAR(1) = IPARS1
27554 IPAR(2) = IPARS2
27555C reset mother-daugther relations
27556 NHEP = NHEPS
27557 JDAHEP(1,IMOTH1) = JDA11
27558 JDAHEP(2,IMOTH1) = JDA21
27559 JDAHEP(1,IMOTH2) = JDA12
27560 JDAHEP(2,IMOTH2) = JDA22
27561 ISTHEP(IMOTH1) = ISTH1
27562 ISTHEP(IMOTH2) = ISTH2
27563 IPOIX1 = IPOIS1
27564 IPOIX2 = IPOIS2
27565 IPOIX3 = IPOIS3
27566C
27567 NSLP = 0
27568 NCOR = 0
27569 55 CONTINUE
27570
27571C calculation of kinematics
27572 DO 100 I=1,2
27573C sampling of masses
27574 IRPDG(I) = 0
27575 IRBAM(I) = 0
27576 IFL1P(I) = IDPDG(I)
27577 IFL2P(I) = IDBAM(I)
27578 IVEC(I) = 0
27579 IDIR(I) = 0
27580 ISAM(I) = 0
27581 JSAM(I) = 0
27582 KSAM(I) = 0
27583 IF(IPAR(I).EQ.0) THEN
27584C vector meson dominance assumed
27585 XMASS(I) = AMP(I)
27586 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27587C diffraction dissociation
27588 ELSE IF(IPAR(I).EQ.1) THEN
27589 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27590 PREF2 = PMASSD(I)**2
27591 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27592 ELSE
27593 WRITE(LO,'(/1X,A,2I3)')
27594 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27595 CALL PHO_ABORT
27596 ENDIF
27597 100 CONTINUE
27598
27599C sampling of momentum transfer
27600 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27601 & THRM2,TT,SLWGHT,IREJ)
27602 IF(IREJ.NE.0) THEN
27603 NSLP=NSLP+1
27604 IF(NSLP.LT.100) GOTO 55
27605 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27606 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27607 IREJ = 5
27608 RETURN
27609 ENDIF
27610
27611C correct for t-M^2 correlation in diffraction
27612 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27613 NCOR=NCOR+1
27614 IF(NCOR.LT.100) GOTO 55
27615 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27616 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27617 IREJ = 5
27618 RETURN
27619 ENDIF
27620
27621C debug output
27622 IF(IDEB(45).GE.5) THEN
27623 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27624 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27625 ENDIF
27626C not double pomeron scattering
27627 IF(IMODE.NE.2) THEN
27628C sample diffractive interaction processes
27629 DO 120 I=1,2
27630 IF(IPAR(I).NE.0) THEN
27631C find particle combination
27632 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27633 IP = 2
27634 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27635 IP = 3
27636 ELSE IF(IDPDG(I).EQ.990) THEN
27637 IP = 4
27638 ELSE
27639 IP = I+1
27640 ENDIF
27641C sample dissociation process
27642 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27643 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27644 & KSAM(I),IDIR(I))
27645 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27646C store process label
27647 IF(IDIR(I).GT.0) THEN
27648 IPAR(I) = 4
27649 ELSE IF(KSAM(I).GT.0) THEN
27650 IPAR(I) = 3
27651 ELSE IF(ISAM(I).GT.0) THEN
27652 IPAR(I) = 2
27653 ELSE
27654 IPAR(I) = 1
27655C mass fine correction
27656 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27657 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27658 XMASS(I) = XMNEW
27659 ENDIF
27660 ELSE
27661C diffractive pomeron-hadron interaction
27662 IPAR(I) = 10+IPROC(I)
27663 ENDIF
27664C debug output
27665 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27666 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27667 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27668 ENDIF
27669 120 CONTINUE
27670 ENDIF
27671C actualize debug information
27672 IF(IMODE.EQ.1) THEN
27673 IDIFR1 = IPAR(1)
27674 IDIFR2 = IPAR(2)
27675 ENDIF
27676C calculate new momenta in CMS
27677 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27678 IF(IREJ.NE.0) GOTO 50
27679 DO 130 I=1,4
27680 PP(I,1) = P1(I)
27681 PP(I,2) = P2(I)
27682 130 CONTINUE
27683
27684C comment line for diffraction
27685 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27686 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27687C write diffractive strings/particles
27688 DO 200 I=1,2
27689 I1 = I
27690 I2 = 3-I1
27691 DO K=1,4
27692 PD1(K) = PP(K,I1)
27693 PD2(K) = PP(K,I2)
27694 ENDDO
27695 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27696 PP(7,I1) = TT
27697 IGEN = IPHIST(2,NPOSD(I1))
27698 if(IGEN.eq.0) IGEN = -I1*10
27699 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27700 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27701 IF(IREJ.NE.0) THEN
27702 IFAIL(7+I) = IFAIL(7+I)+1
27703 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27704 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27705 & I,IPAR(I),XMASS(I)
27706 GOTO 50
27707 ENDIF
27708 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27709 200 CONTINUE
27710C double-pomeron scattering?
27711 IF(IMODE.EQ.2) GOTO 150
27712
27713C diffractive final states
27714 DO 300 I=1,2
27715 110 CONTINUE
27716 IF(IPAR(I).EQ.0) THEN
27717C vector meson production
27718 IF(IDPDG(I).EQ.22) THEN
27719 IF(ISWMDL(21).GE.0) THEN
27720 ISP = IPAMDL(3)
27721 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27722 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27723 ENDIF
27724C hadronic state of multi-pomeron coupling
27725 ELSE IF(IDPDG(I).EQ.990) THEN
27726 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27727 ENDIF
27728 ELSE
27729 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27730 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27731 IF(IDIR(I).GT.0) THEN
27732 IPAR(I) = 4
27733 ELSE IF(KSAM(I).GT.0) THEN
27734 IPAR(I) = 3
27735 ELSE IF(ISAM(I).GT.0) THEN
27736 IPAR(I) = 2
27737 ELSE
27738 IPAR(I) = 1
27739 ENDIF
27740 ELSE
27741 IPAR(I) = 10+IPROC(I)
27742 ENDIF
27743 IPHIST(I,ICPOS) = IPAR(I)
27744C update debug informantion
27745 KSPOM = ISAM(I)
27746 KSREG = JSAM(I)
27747 KHPOM = KSAM(I)
27748 KHDIR = IDIR(I)
27749 IDIFR1 = IPAR(1)
27750 IDIFR2 = IPAR(2)
27751 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27752
27753C resonance decay, pi+pi- background
27754 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27755 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27756 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27757 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27758 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27759 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27760C decay
27761 IF(IDPDG(I).EQ.22) THEN
27762 IPHIST(2,IPOS) = 3
27763 IF(ISWMDL(21).GE.0) THEN
27764 ISP = IPAMDL(3)
27765 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27766 CALL PHO_SDECAY(IPOS,ISP,2)
27767 ENDIF
27768 ELSE
27769 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27770 ENDIF
27771 IREJ = 0
27772 ELSE
27773
27774C particle-pomeron scattering
27775 IF(IPAR(I).LE.4) THEN
27776C non-diffractive particle-pomeron scattering
27777 IGEN = IPHIST(2,NPOSD(I))
27778 if(IGEN.eq.0) then
27779 if(I.eq.1) then
27780 IGEN = 5
27781 else
27782 IGEN = 6
27783 endif
27784 endif
27785 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27786 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27787 ELSE
27788C diffractive particle-pomeron scattering
27789 IPOIX2 = IPOIX2+1
27790 IPORES(IPOIX2) = IPROC(I)
27791 IPOPOS(1,IPOIX2) = IPOSP(1,I)
27792 IPOPOS(2,IPOIX2) = IPOSP(2,I)
27793 ENDIF
27794 ENDIF
27795 ENDIF
27796
27797C rejection?
27798 IF(IREJ.NE.0) THEN
27799 IFAIL(20+I) = IFAIL(20+I)+1
27800 IF(IPAR(I).GT.1) THEN
27801 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27802 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27803 IF(IDIR(I).GT.0) THEN
27804 IDIR(I) = 0
27805 ELSE IF(KSAM(I).GT.0) THEN
27806 KSAM(I) = KSAM(I)-1
27807 ELSE IF(ISAM(I).GT.0) THEN
27808 ISAM(I) = ISAM(I)-1
27809 ENDIF
27810 GOTO 110
27811 ELSE
27812 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27813 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27814 & I,IPAR(I),XMASS(I)
27815 GOTO 50
27816 ENDIF
27817 ENDIF
27818 300 CONTINUE
27819
27820 IDIF1 = IPAR(1)
27821 IDIF2 = IPAR(2)
27822C update debug information
27823 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27824 KSREG = KSREGS+JSAM(1)+JSAM(2)
27825 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27826 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27827
27828 150 CONTINUE
27829
27830C debug output
27831 IF(IDEB(45).GE.10) THEN
27832 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27833 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27834 & IPAR,NPOSD,MSOFT,MHARD,IMODE
27835 ENDIF
27836 IF(IDEB(45).GE.15) THEN
27837 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27838 & '------------------------------'
27839 CALL PHO_PREVNT(0)
27840 ENDIF
27841
27842 END
27843
27844*$ CREATE PHO_DIFPRO.FOR
27845*COPY PHO_DIFPRO
27846CDECK ID>, PHO_DIFPRO
27847 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27848 & IPROC,ISAM,JSAM,KSAM,IDIR)
27849C*********************************************************************
27850C
27851C sampling of diffraction dissociation process
27852C
27853C input: IP particle combination
27854C ICUT user imposed limitations
27855C ID1/2 PDG particle code of scattering particles
27856C XMASS diffractively produced mass (GeV)
27857C P2V1/2 virtuality of scattering particles (Gev**2)
27858C SPROB suppression factor for resolved single and
27859C double diffraction dissociation
27860C
27861C output: IRPOC process ID
27862C ISAM number of cut pomerons (soft)
27863C JSAM number of cut reggeons
27864C KSAM number of cut pomerons (hard)
27865C IDIR direct hard interaction
27866C
27867C*********************************************************************
27868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27869 SAVE
27870
27871C input/output channels
27872 INTEGER LI,LO
27873 COMMON /POINOU/ LI,LO
27874C event debugging information
27875 INTEGER NMAXD
27876 PARAMETER (NMAXD=100)
27877 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27878 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27879 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27880 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27881C general process information
27882 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27883 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27884C model switches and parameters
27885 CHARACTER*8 MDLNA
27886 INTEGER ISWMDL,IPAMDL
27887 DOUBLE PRECISION PARMDL
27888 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27889C energy-interpolation table
27890 INTEGER IEETA2
27891 PARAMETER ( IEETA2 = 20 )
27892 INTEGER ISIMAX
27893 DOUBLE PRECISION SIGTAB,SIGECM
27894 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27895
27896 ISAM = 0
27897 JSAM = 0
27898 KSAM = 0
27899 IDIR = 0
27900
27901 IF(XMASS.GT.3.D0) THEN
27902C rapidity gap survival probability
27903 SPRO = 1.D0
27904 IF(ISWMDL(28).GE.1) SPRO = SPROB
27905C sample interaction
27906 IPROC = 0
27907 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27908 ELSE
27909 IPROC = 1
27910 ENDIF
27911 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27912C non-diffractive hadron-pomeron interaction
27913 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27914C option for suppression of multiple interaction
27915 IF(ICUT.EQ.0) THEN
27916 IPROC = 1
27917 IF(ISAM+KSAM+IDIR.GT.0) THEN
27918 ISAM = 1
27919 JSAM = 0
27920 ELSE
27921 JSAM = 1
27922 ENDIF
27923 KSAM = 0
27924 IDIR = 0
27925 ELSE IF(ICUT.EQ.1) THEN
27926 IF(IDIR.GT.0) THEN
27927 ELSE IF(KSAM.GT.0) THEN
27928 KSAM = 1
27929 ISAM = 0
27930 JSAM = 0
27931 ELSE IF(ISAM.GT.0) THEN
27932 ISAM = 1
27933 JSAM = 0
27934 ELSE
27935 JSAM = 1
27936 ENDIF
27937 ELSE IF(ICUT.EQ.2) THEN
27938 KSAM = MIN(KSAM,1)
27939 ELSE IF(ICUT.EQ.3) THEN
27940 ISAM = MIN(ISAM,1)
27941 ENDIF
27942 ENDIF
27943 END
27944
27945*$ CREATE PHO_DIFPAR.FOR
27946*COPY PHO_DIFPAR
27947CDECK ID>, PHO_DIFPAR
27948 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27949 & IPOSH1,IPOSH2,IMODE,IREJ)
27950C***********************************************************************
27951C
27952C perform string construction for diffraction dissociation
27953C
27954C input: IMOTH1,2 index of mother particles in POEVT1
27955C IGENM production process of mother particles
27956C IFL1,IFL2 particle numbers
27957C (IDPDG,IDBAM for quasi-elas. hadron)
27958C IPAR 0 quasi-elasic scattering
27959C 1 single string configuration
27960C 2 two string configuration
27961C P1 massive 4 momentum of first
27962C P1(6) virtuality/squ.mass of particle (GeV**2)
27963C P1(7) virtuality of Pomeron (neg, GeV**2)
27964C P2 massive 4 momentum of second particle
27965C IMODE 1 diffraction dissociation
27966C 2 double-pomeron scattering
27967C
27968C output: IPOSH1,2 index of the particles in /POEVT1/
27969C IREJ 0 successful string construction
27970C 1 no string construction possible
27971C
27972C***********************************************************************
27973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27974 SAVE
27975
27976 DIMENSION P1(7),P2(7)
27977
27978 PARAMETER ( EPS = 1.D-7,
27979 & DEPS = 1.D-10)
27980
27981C input/output channels
27982 INTEGER LI,LO
27983 COMMON /POINOU/ LI,LO
27984C event debugging information
27985 INTEGER NMAXD
27986 PARAMETER (NMAXD=100)
27987 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27988 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27989 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27990 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27991C internal rejection counters
27992 INTEGER NMXJ
27993 PARAMETER (NMXJ=60)
27994 CHARACTER*10 REJTIT
27995 INTEGER IFAIL
27996 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27997C c.m. kinematics of diffraction
27998 INTEGER NPOSD
27999 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28000 & SIDD,CODD,SIFD,COFD,PDCMS
28001 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28002 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28003C model switches and parameters
28004 CHARACTER*8 MDLNA
28005 INTEGER ISWMDL,IPAMDL
28006 DOUBLE PRECISION PARMDL
28007 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28008C some constants
28009 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28010 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28011 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28012C standard particle data interface
28013 INTEGER NMXHEP
28014 PARAMETER (NMXHEP=4000)
28015 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28016 DOUBLE PRECISION PHEP,VHEP
28017 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28018 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28019 & VHEP(4,NMXHEP)
28020C extension to standard particle data interface (PHOJET specific)
28021 INTEGER IMPART,IPHIST,ICOLOR
28022 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28023
28024 DIMENSION PCH1(2,4)
28025 data IC1 /0/
28026 data IC2 /0/
28027
28028 IREJ = 0
28029 ILTR1 = NHEP+1
28030 IGEN = IGENM
28031 if(IGENM.le.-10) IGEN = 0
28032
28033C elastic part
28034 IF(IPAR.EQ.0) THEN
28035 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28036 if(IGEN.eq.0) IGEN = 3
28037C pi+/pi- isotropic background
28038 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28039 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28040 CALL PHO_SDECAY(IPOSH1,0,-2)
28041 ELSE
28042 if(IGEN.eq.0) then
28043 IGEN = 2
28044 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28045 endif
28046C registration of particle or resonance
28047 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28048 & P1(4),0,IGEN,0,0,IPOSH1,1)
28049 ENDIF
28050
28051C diffraction dissociation
28052 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28053C calculation of resulting particle momenta
28054 IF(IMOTH1.EQ.NPOSD(1)) THEN
28055 K = 2
28056 ELSE
28057 K = 1
28058 ENDIF
28059 DO 100 I=1,4
28060 PCH1(2,I) = PDCMS(I,K)-P2(I)
28061 PCH1(1,I) = P1(I)-PCH1(2,I)
28062 100 CONTINUE
28063
28064C registration
28065 if(IMODE.LT.2) then
28066 if(IGEN.eq.0) IGEN = -IGENM/10+4
28067 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28068 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28069 else
28070 if(IGEN.eq.0) IGEN = 4
28071 endif
28072 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28073 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28074
28075C invalid IPAR
28076 ELSE
28077 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28078 CALL PHO_ABORT
28079 ENDIF
28080
28081C back transformation
28082 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28083 & GAMBED(1),GAMBED(2),GAMBED(3))
28084
28085 END
28086
28087*$ CREATE PHO_QELAST.FOR
28088*COPY PHO_QELAST
28089CDECK ID>, PHO_QELAST
28090 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28091C**********************************************************************
28092C
28093C sampling of quasi elastic processes
28094C
28095C input: IPROC 2 purely elastic scattering
28096C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28097C IPROC 4 double pomeron scattering
28098C IPROC -1 initialization
28099C IPROC -2 output of statistics
28100C JM1/2 index of initial particle 1/2
28101C
28102C output: initial and final particles in /POEVT1/ involving
28103C polarized resonances in /POEVT1/ and decay
28104C products
28105C
28106C IREJ 0 successful
28107C 1 failure
28108C 50 user rejection
28109C
28110C**********************************************************************
28111 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28112 SAVE
28113
28114 PARAMETER ( NTAB = 20,
28115 & EPS = 1.D-10,
28116 & PIMASS = 0.13D0,
28117 & DEPS = 1.D-10)
28118
28119C input/output channels
28120 INTEGER LI,LO
28121 COMMON /POINOU/ LI,LO
28122C event debugging information
28123 INTEGER NMAXD
28124 PARAMETER (NMAXD=100)
28125 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28126 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28127 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28128 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28129C global event kinematics and particle IDs
28130 INTEGER IFPAP,IFPAB
28131 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28132 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28133C c.m. kinematics of diffraction
28134 INTEGER NPOSD
28135 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28136 & SIDD,CODD,SIFD,COFD,PDCMS
28137 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28138 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28139C model switches and parameters
28140 CHARACTER*8 MDLNA
28141 INTEGER ISWMDL,IPAMDL
28142 DOUBLE PRECISION PARMDL
28143 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28144C some constants
28145 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28146 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28147 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28148C cross sections
28149 INTEGER IPFIL,IFAFIL,IFBFIL
28150 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28151 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28152 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28153 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28154 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28155 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28156 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28157 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28158 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28159 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28160 & IPFIL,IFAFIL,IFBFIL
28161C standard particle data interface
28162 INTEGER NMXHEP
28163 PARAMETER (NMXHEP=4000)
28164 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28165 DOUBLE PRECISION PHEP,VHEP
28166 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28167 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28168 & VHEP(4,NMXHEP)
28169C extension to standard particle data interface (PHOJET specific)
28170 INTEGER IMPART,IPHIST,ICOLOR
28171 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28172
28173 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28174 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28175 DIMENSION IFL(2),IDPRO(4)
28176 character*15 pho_pname
28177 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28178 DIMENSION ISAMVM(4,4)
28179 DATA IDPRO / 113,223,333,92 /
28180 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28181 & 'pi+pi- ' /
28182 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28183 & 'pi+pi- ' /
28184
28185C sampling of elastic/quasi-elastic processes
28186 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28187 IREJ = 0
28188 NPOSD(1) = JM1
28189 NPOSD(2) = JM2
28190 DO 55 I=1,2
28191 PMI(I) = PHEP(5,NPOSD(I))
28192 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28193 55 CONTINUE
28194C get CM system
28195 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28196 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28197 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28198 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28199 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28200 ECMD = SQRT(SS)
28201
28202 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28203 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28204 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28205 & ECMD,PMI
28206 IREJ = 5
28207 RETURN
28208 ENDIF
28209
28210 DO 60 I=1,4
28211 GAMBED(I) = PK1(I)/ECMD
28212 60 CONTINUE
28213 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28214 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28215 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28216C rotation angles
28217 CODD = PK1(3)/PTOT1
28218 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28219 COFD = 1.D0
28220 SIFD = 0.D0
28221 IF(PTOT1*SIDD.GT.1.D-5) THEN
28222 COFD = PK1(1)/(SIDD*PTOT1)
28223 SIFD = PK1(2)/(SIDD*PTOT1)
28224 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28225 COFD = COFD/ANORF
28226 SIFD = SIFD/ANORF
28227 ENDIF
28228C get CM momentum
28229 AM12 = PMI(1)**2
28230 AM22 = PMI(2)**2
28231 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28232
28233C production process of mother particles
28234 IGEN = IPHIST(2,NPOSD(1))
28235 if(IGEN.eq.0) IGEN = IPROC
28236
28237 ICALL = ICALL + 1
28238C main rejection label
28239 50 CONTINUE
28240C determine process and final particles
28241 IFL(1) = IDHEP(NPOSD(1))
28242 IFL(2) = IDHEP(NPOSD(2))
28243 IF(IPROC.EQ.3) THEN
28244 ITRY = 0
28245 100 CONTINUE
28246 ITRY = ITRY+1
28247 IF(ITRY.GT.50) THEN
28248 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28249 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28250 & ITRY,ECMD
28251 IREJ = 5
28252 RETURN
28253 ENDIF
28254 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28255 DO 110 I=1,4
28256 DO 120 J=1,4
28257 XI = XI-SIGVM(I,J)
28258 IF(XI.LE.0.D0) GOTO 130
28259 120 CONTINUE
28260 110 CONTINUE
28261 130 CONTINUE
28262 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28263 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28264 ISAMVM(I,J) = ISAMVM(I,J)+1
28265 ISAMQE = ISAMQE+1
28266C sample new masses
28267 CALL PHO_SAMASS(IFL(1),RMASS(1))
28268 CALL PHO_SAMASS(IFL(2),RMASS(2))
28269 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28270 ELSE IF(IPROC.EQ.2) THEN
28271 I = 0
28272 J = 0
28273 ISAMEL = ISAMEL+1
28274 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28275 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28276 ELSE
28277 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28278 CALL PHO_ABORT
28279 ENDIF
28280C sample momentum transfer
28281 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28282 & SLWGHT,IREJ)
28283 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28284 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28285C calculate new momenta
28286 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28287 IF(IREJ.NE.0) GOTO 50
28288 DO K=1,4
28289 P(K,1) = PK1(K)
28290 P(K,2) = PK2(K)
28291 ENDDO
28292C comment line for elastic/quasi-elastic scattering
28293 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28294 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28295
28296 I1 = NHEP+1
28297C fill /POEVT1/
28298 DO 200 I=1,2
28299 K = 3-I
28300 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28301C pi+/pi- isotropic background
28302 IGEN = 3
28303 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28304 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28305 ICOLOR(I,ICPOS) = IPOS
28306 CALL PHO_SDECAY(IPOS,0,-2)
28307 ELSE
28308C registration
28309 IGEN = 2
28310 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28311 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28312 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28313 ICOLOR(I,ICPOS) = IPOS
28314 ENDIF
28315 200 CONTINUE
28316 I2 = NHEP
28317C search for vector mesons
28318 DO 300 I=I1,I2
28319C decay according to polarization
28320 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28321 ISP = IPAMDL(3)
28322 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28323 CALL PHO_SDECAY(I,ISP,2)
28324 ENDIF
28325 300 CONTINUE
28326 I2 = NHEP
28327C back transformation
28328 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28329 & GAMBED(2),GAMBED(3))
28330
28331C initialization of tables
28332 ELSE IF(IPROC.EQ.-1) THEN
28333 DO 10 I=1,4
28334 DO 20 J=1,4
28335 ISAMVM(I,J) = 0
28336 20 CONTINUE
28337 10 CONTINUE
28338 ISAMEL = 0
28339 ISAMQE = 0
28340 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28341 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28342 CALL PHO_SAMASS(-1,RMASS(1))
28343 ICALL = 0
28344
28345C output of statistics
28346 ELSE IF(IPROC.EQ.-2) THEN
28347 IF(ICALL.LT.10) RETURN
28348 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28349 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28350 & '---------------------------------------------------'
28351 WRITE(LO,'(1X,A,I10)')
28352 & 'sampled elastic processes:',ISAMEL
28353 WRITE(LO,'(1X,A,I10)')
28354 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28355 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28356 DO 30 I=1,4
28357 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28358 30 CONTINUE
28359 CALL PHO_SAMASS(-2,RMASS(1))
28360 ELSE
28361 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28362 & 'unknown process ID',IPROC
28363 CALL PHO_ABORT
28364 ENDIF
28365
28366 END
28367
28368*$ CREATE PHO_CDIFF.FOR
28369*COPY PHO_CDIFF
28370CDECK ID>, PHO_CDIFF
28371 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28372C**********************************************************************
28373C
28374C preparation of /POEVT1/ for double-pomeron scattering
28375C
28376C input: IMOTH1/2 index of mother particles in /POEVT1/
28377C
28378C IMODE 1 sampling of pomeron-pomeron scattering
28379C -1 initialization
28380C -2 output of statistics
28381C
28382C output: MSOFT number of generated soft strings
28383C MHARD number of generated hard strings
28384C IREJ 0 accepted
28385C 1 rejected
28386C 50 user rejection
28387C
28388C**********************************************************************
28389 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28390 SAVE
28391
28392 PARAMETER ( EPS = 1.D-10,
28393 & DEPS = 1.D-10)
28394
28395C input/output channels
28396 INTEGER LI,LO
28397 COMMON /POINOU/ LI,LO
28398C event debugging information
28399 INTEGER NMAXD
28400 PARAMETER (NMAXD=100)
28401 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28402 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28404 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28405C internal rejection counters
28406 INTEGER NMXJ
28407 PARAMETER (NMXJ=60)
28408 CHARACTER*10 REJTIT
28409 INTEGER IFAIL
28410 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28411C model switches and parameters
28412 CHARACTER*8 MDLNA
28413 INTEGER ISWMDL,IPAMDL
28414 DOUBLE PRECISION PARMDL
28415 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28416C general process information
28417 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28418 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28419C Reggeon phenomenology parameters
28420 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28421 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28422 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28423 & ALREG,ALREGP,GR(2),B0REG(2),
28424 & GPPP,GPPR,B0PPP,B0PPR,
28425 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28426C parameters of 2x2 channel model
28427 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28428 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28429C some constants
28430 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28431 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28432 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28433C energy-interpolation table
28434 INTEGER IEETA2
28435 PARAMETER ( IEETA2 = 20 )
28436 INTEGER ISIMAX
28437 DOUBLE PRECISION SIGTAB,SIGECM
28438 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28439C table of particle indices for recursive PHOJET calls
28440 INTEGER MAXIPX
28441 PARAMETER ( MAXIPX = 100 )
28442 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28443 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28444 & IPOIX1,IPOIX2,IPOIX3
28445C standard particle data interface
28446 INTEGER NMXHEP
28447 PARAMETER (NMXHEP=4000)
28448 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28449 DOUBLE PRECISION PHEP,VHEP
28450 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28451 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28452 & VHEP(4,NMXHEP)
28453C extension to standard particle data interface (PHOJET specific)
28454 INTEGER IMPART,IPHIST,ICOLOR
28455 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28456
28457 DIMENSION PD(4)
28458
28459 if(IMODE.ne.1) return
28460
28461 IREJ = 0
28462 IP = 4
28463C select first diffraction
28464 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28465 IPAR1 = 1
28466 IPAR2 = 0
28467 ELSE
28468 IPAR1 = 0
28469 IPAR2 = 1
28470 ENDIF
28471 ITRY2 = 0
28472 ITRYM = 1000
28473
28474C save current status
28475 MSOFT = 0
28476 MHARD = 0
28477 KHPOMS = KHPOM
28478 KSPOMS = KSPOM
28479 KSREGS = KSREG
28480 KHDIRS = KHDIR
28481 IPOIS1 = IPOIX1
28482 IPOIS2 = IPOIX2
28483 IPOIS3 = IPOIX3
28484 JDA11 = JDAHEP(1,IMOTH1)
28485 JDA21 = JDAHEP(2,IMOTH1)
28486 JDA12 = JDAHEP(1,IMOTH2)
28487 JDA22 = JDAHEP(2,IMOTH2)
28488 ISTH1 = ISTHEP(IMOTH1)
28489 ISTH2 = ISTHEP(IMOTH2)
28490 NHEPS = NHEP
28491
28492C find mother particle production process
28493 IGEN = IPHIST(2,IMOTH1)
28494 if(IGEN.eq.0) IGEN = 4
28495
28496C main generation loop
28497 60 CONTINUE
28498
28499 KSPOM = KSPOMS
28500 KHPOM = KHPOMS
28501 KHDIR = KHDIRS
28502 KSREG = KSREGS
28503 I1 = IPAR1
28504 I2 = IPAR2
28505C reset mother-daugther relations
28506 NHEP = NHEPS
28507 JDAHEP(1,IMOTH1) = JDA11
28508 JDAHEP(2,IMOTH1) = JDA21
28509 JDAHEP(1,IMOTH2) = JDA12
28510 JDAHEP(2,IMOTH2) = JDA22
28511 ISTHEP(IMOTH1) = ISTH1
28512 ISTHEP(IMOTH2) = ISTH2
28513 IPOIX1 = IPOIS1
28514 IPOIX2 = IPOIS2
28515 IPOIX3 = IPOIS3
28516C rejection counter
28517 ITRY2 = ITRY2+1
28518 IF(ITRY2.GT.1) THEN
28519 IFAIL(39) = IFAIL(39)+1
28520 IF(ITRY2.GE.ITRYM) GOTO 50
28521 ENDIF
28522C generate two diffractive events
28523 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28524 IF(IREJ.NE.0) GOTO 50
28525 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28526 IF(IREJ.NE.0) GOTO 50
28527C mass of pomeron-pomeron system
28528 DO 100 I2 = NHEP,1,-1
28529 IF(IDHEP(I2).EQ.990) GOTO 110
28530 100 CONTINUE
28531 110 CONTINUE
28532 DO 120 I1 = I2-1,1,-1
28533 IF(IDHEP(I1).EQ.990) GOTO 130
28534 120 CONTINUE
28535 130 CONTINUE
28536 DO 140 I=1,4
28537 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28538 140 CONTINUE
28539 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28540 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28541 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28542 IF(XMASS.LT.0.1D0) GOTO 60
28543 XMASS = SQRT(XMASS)
28544 IF(XMASS.LT.PARMDL(71)) GOTO 60
28545
28546C sample pomeron-pomeron interaction process
28547 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28548 & IPROC,ISAM,JSAM,KSAM,IDIR)
28549
28550C non-diffractive pomeron-pomeron interactions
28551 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28552 200 CONTINUE
28553 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28554C debug output
28555 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28556 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28557 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28558C store debug information
28559 IF(IDIR.GT.0) THEN
28560 IPAR = 4
28561 ELSE IF(KSAM.GT.0) THEN
28562 IPAR = 3
28563 ELSE IF(ISAM.GT.0) THEN
28564 IPAR = 2
28565 ELSE
28566 IPAR = 1
28567 ENDIF
28568 IDDPOM = IPAR
28569 IF(ISAM+JSAM.GT.0) KSDPO = 1
28570 IF(KSAM+IDIR.GT.0) KHDPO = 1
28571 KSPOM = ISAM
28572 KSREG = JSAM
28573 KHPOM = KSAM
28574 KHDIR = IDIR
28575 KSTRG = 0
28576 KSLOO = 0
28577C generate pomeron-pomeron interaction
28578 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28579 IF(IREJ.NE.0) THEN
28580 IFAIL(3) = IFAIL(3)+1
28581 IF(IPAR.GT.1) THEN
28582 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28583 IF(IDIR.GT.0) THEN
28584 IFAIL(10) = IFAIL(10)+1
28585 IDIR = 0
28586 ELSE IF(KSAM.GT.0) THEN
28587 KSAM = KSAM-1
28588 ELSE IF(ISAM.GT.0) THEN
28589 ISAM = ISAM-1
28590 ENDIF
28591 GOTO 200
28592 ELSE
28593 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28594 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28595 & I,IPAR,XMASS
28596 GOTO 50
28597 ENDIF
28598 ENDIF
28599
28600C diffractive pomeron-pomeron interactions
28601 ELSE
28602 IPOIX2 = IPOIX2+1
28603 IPORES(IPOIX2) = IPROC
28604 IPOPOS(1,IPOIX2) = I1
28605 IPOPOS(2,IPOIX2) = I2
28606 IPAR = 10+IPROC
28607 IDDPOM = IPAR
28608 ENDIF
28609
28610C update debug information
28611 KSPOM = KSPOMS+ISAM
28612 KSREG = KSREGS+JSAM
28613 KHPOM = KHPOMS+KSAM
28614 KHDIR = KHDIRS+IDIR
28615C comment line for central diffraction
28616 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28617 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28618 PHEP(5,IPOS) = XMASS
28619C debug output
28620 IF(IDEB(59).GE.15) THEN
28621 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28622 & '-----------------------------'
28623 CALL PHO_PREVNT(0)
28624 ENDIF
28625 RETURN
28626
28627C treatment of rejection
28628 50 CONTINUE
28629 IREJ = 1
28630 IFAIL(40) = IFAIL(40)+1
28631 IF(IDEB(59).GE.3) THEN
28632 WRITE(LO,'(1X,A)')
28633 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28634 IF(IDEB(59).GE.10) THEN
28635 CALL PHO_PREVNT(0)
28636 ELSE
28637 CALL PHO_PREVNT(-1)
28638 ENDIF
28639 ENDIF
28640
28641 END
28642
28643*$ CREATE PHO_SAMASS.FOR
28644*COPY PHO_SAMASS
28645CDECK ID>, PHO_SAMASS
28646 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28647C**********************************************************************
28648C
28649C resonance mass sampling of quasi elastic processes
28650C
28651C input: IFLA PDG number of particle
28652C IFLA -1 initialization
28653C IFLA -2 output of statistics
28654C
28655C output: RMASS particle mass (in GeV)
28656C
28657C**********************************************************************
28658 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28659 SAVE
28660
28661 PARAMETER(EPS = 1.D-10 )
28662
28663C input/output channels
28664 INTEGER LI,LO
28665 COMMON /POINOU/ LI,LO
28666C event debugging information
28667 INTEGER NMAXD
28668 PARAMETER (NMAXD=100)
28669 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28670 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28671 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28672 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28673C model switches and parameters
28674 CHARACTER*8 MDLNA
28675 INTEGER ISWMDL,IPAMDL
28676 DOUBLE PRECISION PARMDL
28677 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28678C parameters of the "simple" Vector Dominance Model
28679 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28680 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28681
28682 PARAMETER(NTABM=50)
28683 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28684 DIMENSION SUM(4),ICALL(4)
28685
28686C*****************************************************************
28687C initialization of tables
28688 IF(IFLA.EQ.-1) THEN
28689C
28690 NSTEP = NTABM
28691 DO 102 I=1,4
28692 ICALL(I) = 0
28693 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28694 DO 105 K=1,NSTEP
28695 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28696 105 CONTINUE
28697 102 CONTINUE
28698C calculate table of dsig/dm
28699 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28700C output of table
28701 IF(IDEB(35).GE.1) THEN
28702 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28703 WRITE(LO,'(1X,A,/1X,A)')
28704 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28705 & ' -------------------------------------------------------'
28706 DO 106 K=1,NSTEP
28707 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28708 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28709 106 CONTINUE
28710 ENDIF
28711C make second table for sampling
28712 DO 109 I=1,4
28713 SUM(I) = 0.D0
28714 DO 108 K=2,NSTEP
28715 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28716 XMC(I,K) = SUM(I)
28717 108 CONTINUE
28718 109 CONTINUE
28719C normalization
28720 DO 118 K=1,NSTEP
28721 DO 119 I=1,4
28722 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28723 119 CONTINUE
28724 118 CONTINUE
28725 IF(IDEB(35).GE.10) THEN
28726 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28727 WRITE(LO,'(1X,A,/1X,A)')
28728 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28729 & ' -------------------------------------------------------'
28730 DO 120 K=1,NSTEP
28731 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28732 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28733 120 CONTINUE
28734 ENDIF
28735C
28736C**************************************************
28737C output of statistics
28738 ELSE IF(IFLA.EQ.-2) THEN
28739 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28740 & '----------------------'
28741 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
28742 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
28743C
28744C********************************************************
28745C sampling of RMASS
28746 ELSE
28747C quasi-elastic vector meson production
28748 IF(IFLA.EQ.113) THEN
28749 KP = 1
28750 ELSE IF(IFLA.EQ.223) THEN
28751 KP = 2
28752 ELSE IF(IFLA.EQ.333) THEN
28753 KP = 3
28754 ELSE IF(IFLA.EQ.92) THEN
28755 KP = 4
28756C quasi-elastic production of h*
28757 ELSE IF(IFLA.EQ.91) THEN
28758 RMASS = 0.35D0
28759 RETURN
28760C elastic hadron scattering
28761 ELSE
28762 RMASS = PHO_PMASS(IFLA,1)
28763 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28764 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28765 RETURN
28766 ENDIF
28767C
28768C sample mass of vector mesonsn / two-pi background
28769 XI = DT_RNDM(RMASS) + EPS
28770C binary search
28771 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28772 KMIN=1
28773 KMAX=NSTEP
28774 300 CONTINUE
28775 IF((KMAX-KMIN).EQ.1) GOTO 400
28776 KK=(KMAX+KMIN)/2
28777 IF(XI.LE.XMC(KP,KK)) THEN
28778 KMAX=KK
28779 ELSE
28780 KMIN=KK
28781 ENDIF
28782 GOTO 300
28783 400 CONTINUE
28784 ELSE
28785 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28786 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28787 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28788 CALL PHO_ABORT
28789 ENDIF
28790C fine interpolation
28791 RMASS = RMA(KP,KMIN)+
28792 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
28793 & (XMC(KP,KMAX)-XMC(KP,KMIN))
28794 & *(XI-XMC(KP,KMIN))
28795 IF(IDEB(35).GE.20) THEN
28796 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28797 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28798 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28799 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28800 & IFLA,RMASS
28801 ENDIF
28802 ICALL(KP) = ICALL(KP)+1
28803 ENDIF
28804 END
28805
28806*$ CREATE PHO_DSIGDM.FOR
28807*COPY PHO_DSIGDM
28808CDECK ID>, PHO_DSIGDM
28809 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28810C**********************************************************************
28811C
28812C differential cross section DSIG/DM of low mass enhancement
28813C
28814C input: RMA(4,NTABM) mass values
28815C output: XMA(4,NTABM) DSIG/DM of resonances
28816C 1 rho production
28817C 2 omega production
28818C 3 phi production
28819C 4 pi-pi continuum
28820C
28821C**********************************************************************
28822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28823 SAVE
28824
28825 PARAMETER ( EPS = 1.D-10 )
28826
28827 PARAMETER(NTABM=50)
28828 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28829
28830C input/output channels
28831 INTEGER LI,LO
28832 COMMON /POINOU/ LI,LO
28833C event debugging information
28834 INTEGER NMAXD
28835 PARAMETER (NMAXD=100)
28836 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28837 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28838 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28839 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28840C model switches and parameters
28841 CHARACTER*8 MDLNA
28842 INTEGER ISWMDL,IPAMDL
28843 DOUBLE PRECISION PARMDL
28844 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28845C parameters of the "simple" Vector Dominance Model
28846 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28847 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28848
28849 PIMASS = 0.135
28850C rho meson shape (mass dependent width)
28851 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28852 DO 100 I=1,NSTEP
28853 XMASS = RMA(1,I)
28854 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28855 GAMMA = GAMM(1)*(QQ/QRES)**3
28856 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28857 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28858 100 CONTINUE
28859C omega/phi meson (constant width)
28860 DO 200 K=2,3
28861 DO 300 I=1,NSTEP
28862 XMASS = RMA(K,I)
28863 XMA(K,I) = XMASS*GAMM(K)
28864 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28865 300 CONTINUE
28866 200 CONTINUE
28867C pi-pi continuum
28868 DO 400 I=1,NSTEP
28869 XMASS = RMA(4,I)
28870 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28871 400 CONTINUE
28872
28873 END
28874
28875*$ CREATE PHO_SDECAY.FOR
28876*COPY PHO_SDECAY
28877CDECK ID>, PHO_SDECAY
28878 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28879C**********************************************************************
28880C
28881C decay of single resonance of /POEVT1/:
28882C decay in helicity frame according to polarization, isotropic
28883C decay and decay with limited transverse phase space possible
28884C
28885C ATTENTION:
28886C reference to particle number of CPC has to exist
28887C
28888C input: NPOS position in /POEVT1/
28889C ISP 0 decay according to phase space
28890C 1 decay according to transversal polarization
28891C 2 decay according to longitudinal polarization
28892C 3 decay with limited phase space
28893C ILEV decay mode to use
28894C 1 strong only
28895C 2 strong and ew of tau, charm, and bottom
28896C 3 strong and electro-weak decays
28897C negative: remove mother resonance after decay
28898C
28899C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28900C
28901C**********************************************************************
28902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28903 SAVE
28904
28905 PARAMETER ( EPS = 1.D-15,
28906 & DEPS = 1.D-10 )
28907
28908C input/output channels
28909 INTEGER LI,LO
28910 COMMON /POINOU/ LI,LO
28911C event debugging information
28912 INTEGER NMAXD
28913 PARAMETER (NMAXD=100)
28914 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28915 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28916 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28917 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28918C model switches and parameters
28919 CHARACTER*8 MDLNA
28920 INTEGER ISWMDL,IPAMDL
28921 DOUBLE PRECISION PARMDL
28922 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28923C some constants
28924 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28925 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28926 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28927C standard particle data interface
28928 INTEGER NMXHEP
28929 PARAMETER (NMXHEP=4000)
28930 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28931 DOUBLE PRECISION PHEP,VHEP
28932 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28933 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28934 & VHEP(4,NMXHEP)
28935C extension to standard particle data interface (PHOJET specific)
28936 INTEGER IMPART,IPHIST,ICOLOR
28937 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28938C general particle data
28939 double precision xm_list,tau_list,gam_list,
28940 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28941 & xm_bb82_list,xm_bb102_list
28942 integer ich3_list,iba3_list,iq_list,
28943 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
28944 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28945 & xm_psm2_list(6,6),xm_vem2_list(6,6),
28946 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28947 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28948 & ich3_list(300),iba3_list(300),iq_list(3,300),
28949 & id_psm_list(6,6),id_vem_list(6,6),
28950 & id_b8_list(6,6,6),id_b10_list(6,6,6)
28951C particle decay data
28952 double precision wg_sec_list
28953 integer idec_list,isec_list
28954 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28955 & isec_list(3,500)
28956C auxiliary data for three particle decay
28957 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28958 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28959
28960 DIMENSION WGHD(20),KCH(20),ID(3)
28961
28962 IMODE = ABS(ILEV)
28963 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28964 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28965
28966C comment entry
28967 IF(ISTHEP(NPOS).GT.11) RETURN
28968
28969C particle stable?
28970 IDcpc = IMPART(NPOS)
28971 IF(IDcpc.EQ.0) return
28972 IDabs = iabs(IDcpc)
28973 if(idec_list(1,IDabs).eq.0) return
28974
28975C different decay modi (times)
28976 IF(IMODE.EQ.1) THEN
28977 if(idec_list(1,IDabs).ne.1) return
28978 ELSE IF(IMODE.EQ.2) THEN
28979 if(idec_list(1,IDabs).gt.2) return
28980 ELSE IF(IMODE.EQ.3) THEN
28981 if(idec_list(1,IDabs).gt.3) return
28982 ELSE
28983 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
28984 CALL PHO_ABORT
28985 ENDIF
28986
28987C decay products, check for mass limitations
28988 K = 0
28989 WGSUM = 0.D0
28990 AMIST = PHEP(5,NPOS)
28991 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
28992 AMSUM = 0.D0
28993 DO 200 L=1,3
28994 ID(L) = isec_list(L,I)
28995 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
28996 200 CONTINUE
28997 IF(AMSUM.LT.AMIST) THEN
28998 K = K+1
28999 WGHD(K) = wg_sec_list(I)
29000 KCH(K) = I
29001 ENDIF
29002 100 CONTINUE
29003 IF(K.EQ.0)THEN
29004 WRITE(LO,'(/1X,A,I6,3E12.4)')
29005 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29006 & NPOS,AMIST,AMSUM
29007 CALL PHO_PREVNT(0)
29008 RETURN
29009 ENDIF
29010
29011C sample new decay channel
29012 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29013 K = 0
29014 WGSUM = 0.D0
29015 500 CONTINUE
29016 K = K+1
29017 WGSUM = WGSUM+WGHD(K)
29018 IF(XI.GT.WGSUM) GOTO 500
29019 IK = KCH(K)
29020 ID(1) = isec_list(1,IK)
29021 ID(2) = isec_list(2,IK)
29022 ID(3) = isec_list(3,IK)
29023 if(IDcpc.lt.0) then
29024 ID(1) = ipho_anti(ID(1))
29025 ID(2) = ipho_anti(ID(2))
29026 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29027 endif
29028
29029C rotation
29030 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29031 CXS = PHEP(1,NPOS)/PTOT
29032 CYS = PHEP(2,NPOS)/PTOT
29033 CZS = PHEP(3,NPOS)/PTOT
29034C boost
29035 GBET = PTOT/AMIST
29036 GAM = PHEP(4,NPOS)/AMIST
29037
29038 IF(ID(3).EQ.0) THEN
29039C two particle decay
29040 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29041 ELSE
29042C three particle decay
29043 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29044 & pho_pmass(ID(3),0),ISP)
29045 ENDIF
29046
29047 IF(ILEV.LT.0) THEN
29048 IF(NHEP.NE.NPOS) THEN
29049 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29050 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29051 CALL PHO_ABORT
29052 ENDIF
29053 IMO1 = JMOHEP(1,NPOS)
29054 IMO2 = JMOHEP(2,NPOS)
29055 NHEP = NHEP-1
29056 ELSE
29057 IMO1 = NPOS
29058 IMO2 = 0
29059 ENDIF
29060 IPH1 = IPHIST(1,NPOS)
29061 IPH2 = IPHIST(2,NPOS)
29062
29063C back transformation and registration
29064 DO 300 I=1,3
29065 IF(ID(I).NE.0) THEN
29066 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29067 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29068 XX = PTOT*CX
29069 YY = PTOT*CY
29070 ZZ = PTOT*CZ
29071 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29072 & IPH1,IPH2,0,0,IPOS,1)
29073 ENDIF
29074 300 CONTINUE
29075
29076 400 CONTINUE
29077C debug output
29078 IF(IDEB(36).GE.20) THEN
29079 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29080 & '--------------------'
29081 CALL PHO_PREVNT(0)
29082 ENDIF
29083
29084 END
29085
29086*$ CREATE PHO_SDECY2.FOR
29087*COPY PHO_SDECY2
29088CDECK ID>, PHO_SDECY2
29089 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29090C**********************************************************************
29091C
29092C isotropic/anisotropic two particle decay in CM system,
29093C (transversely/longitudinally polarized boson into two
29094C pseudo-scalar mesons)
29095C
29096C**********************************************************************
29097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29098 SAVE
29099
29100C input/output channels
29101 INTEGER LI,LO
29102 COMMON /POINOU/ LI,LO
29103C auxiliary data for three particle decay
29104 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29105 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29106
29107 UMO2=UMO*UMO
29108 AM11=AM1*AM1
29109 AM22=AM2*AM2
29110 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29111 ECM(2)=UMO-ECM(1)
29112 WAU=ECM(1)*ECM(1)-AM11
29113 IF(WAU.LT.0.D0) THEN
29114 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29115 CALL PHO_ABORT
29116 ENDIF
29117 PCM(1)=SQRT(WAU)
29118 PCM(2)=PCM(1)
29119
29120 CALL PHO_SFECFE(SIF(1),COF(1))
29121 IF(ISP.EQ.0) THEN
29122C no polarization
29123 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29124 ELSE IF(ISP.EQ.1) THEN
29125C transverse polarization
29126 400 CONTINUE
29127 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29128 SID12 = 1.D0-COD(1)*COD(1)
29129 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29130 ELSE IF(ISP.EQ.2) THEN
29131C longitudinal polarization
29132 500 CONTINUE
29133 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29134 COD12 = COD(1)*COD(1)
29135 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29136 ELSE
29137 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29138 & 'invalid polarization',ISP
29139 CALL PHO_ABORT
29140 ENDIF
29141
29142 COD(2) = -COD(1)
29143 COF(2) = -COF(1)
29144 SIF(2) = -SIF(1)
29145
29146 END
29147
29148*$ CREATE PHO_SDECY3.FOR
29149*COPY PHO_SDECY3
29150CDECK ID>, PHO_SDECY3
29151 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29152C**********************************************************************
29153C
29154C isotropic/anisotropic three particle decay in CM system,
29155C (transversely/longitudinally polarized boson into three
29156C pseudo-scalar mesons)
29157C
29158C**********************************************************************
29159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29160 SAVE
29161
29162 PARAMETER ( DEPS = 1.D-30,
29163 & EPS = 1.D-15 )
29164
29165C input/output channels
29166 INTEGER LI,LO
29167 COMMON /POINOU/ LI,LO
29168C auxiliary data for three particle decay
29169 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29170 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29171
29172 DIMENSION F(5),XX(5)
29173
29174C calculation of maximum of S2 phase space weight
29175 UMOO=UMO+UMO
29176 GU=(AM2+AM3)**2
29177 GO=(UMO-AM1)**2
29178 UFAK=1.0000000000001D0
29179 IF (GU.GT.GO) UFAK=0.99999999999999D0
29180 OFAK=2.D0-UFAK
29181 GU=GU*UFAK
29182 GO=GO*OFAK
29183 DS2=(GO-GU)/99.D0
29184 AM11=AM1*AM1
29185 AM22=AM2*AM2
29186 AM33=AM3*AM3
29187 UMO2=UMO*UMO
29188 RHO2=0.D0
29189 S22=GU
29190 DO 124 I=1,100
29191 S21=S22
29192 S22=GU+(I-1.D0)*DS2
29193 RHO1=RHO2
29194 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29195 IF(RHO2.LT.RHO1) GOTO 125
29196 124 CONTINUE
29197
29198 125 CONTINUE
29199 S2SUP=(S22-S21)/2.D0+S21
29200 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29201 & /(S2SUP+EPS)
29202 SUPRHO=SUPRHO*1.05D0
29203 XO=S21-DS2
29204 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29205 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29206 XX(1)=XO
29207 XX(3)=S22
29208 X1=(XO+S22)*0.5D0
29209 XX(2)=X1
29210 F(3)=RHO2
29211 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29212 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29213 DO 126 I=1,16
29214 X4=(XX(1)+XX(2))*0.5D0
29215 X5=(XX(2)+XX(3))*0.5D0
29216 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29217 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29218 XX(4)=X4
29219 XX(5)=X5
29220 DO 128 II=1,5
29221 IA=II
29222 DO 131 III=IA,5
29223 IF(F(II).LT.F(III)) THEN
29224 FH=F(II)
29225 F(II)=F(III)
29226 F(III)=FH
29227 FH=XX(II)
29228 XX(II)=XX(III)
29229 XX(III)=FH
29230 ENDIF
29231 131 CONTINUE
29232 128 CONTINUE
29233 SUPRHO=F(1)
29234 S2SUP=XX(1)
29235 DO 129 II=1,3
29236 IA=II
29237 DO 130 III=IA,3
29238 IF (XX(II).LT.XX(III)) THEN
29239 FH=F(II)
29240 F(II)=F(III)
29241 F(III)=FH
29242 FH=XX(II)
29243 XX(II)=XX(III)
29244 XX(III)=FH
29245 ENDIF
29246 130 CONTINUE
29247 129 CONTINUE
29248 126 CONTINUE
29249
29250 AM23=(AM2+AM3)**2
29251
29252C selection of S1
29253 ITH=0
29254 200 CONTINUE
29255 ITH=ITH+1
29256 IF(ITH.GT.200) THEN
29257 WRITE(LO,'(/1X,A,I10)')
29258 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29259 CALL PHO_ABORT
29260 ENDIF
29261 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29262 Y=DT_RNDM(AM23)*SUPRHO
29263 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29264 IF(Y.GT.RHO) GOTO 200
29265
29266C selection of S2
29267 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29268 & /(2.D0*S2)-RHO/2.D0
29269 S3=UMO2+AM11+AM22+AM33-S1-S2
29270 ECM(1)=(UMO2+AM11-S2)/UMOO
29271 ECM(2)=(UMO2+AM22-S3)/UMOO
29272 ECM(3)=(UMO2+AM33-S1)/UMOO
29273 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29274 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29275 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29276
29277C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29278 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29279 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29280 ELSE
29281 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29282 ENDIF
29283 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29284 & /(2.D0*PCM(2)*PCM(3))
29285 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29286 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29287 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29288
29289C selection of the sperical coordinates of particle 3
29290 CALL PHO_SFECFE(SIF(3),COF(3))
29291 IF(ISP.EQ.0) THEN
29292C no polarization
29293 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29294 ELSE IF(ISP.EQ.1) THEN
29295C transverse polarization
29296 400 CONTINUE
29297 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29298 SID32 = 1.D0-COD(3)*COD(3)
29299 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29300 ELSE IF(ISP.EQ.2) THEN
29301C longitudinal polarization
29302 500 CONTINUE
29303 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29304 COD32 = COD(3)*COD(3)
29305 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29306 ELSE
29307 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29308 & 'invalid polarization',ISP
29309 CALL PHO_ABORT
29310 ENDIF
29311
29312C selection of the rotation angle of p1-p2 plane along p3
29313 IF(ISP.EQ.0) THEN
29314 CALL PHO_SFECFE(SFE,CFE)
29315 ELSE
29316 SFE = 0.D0
29317 CFE = 1.D0
29318 ENDIF
29319 CX11=-COSTH1
29320 CY11=SINTH1*CFE
29321 CZ11=SINTH1*SFE
29322 CX22=-COSTH2
29323 CY22=-SINTH2*CFE
29324 CZ22=-SINTH2*SFE
29325
29326 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29327 COD(1)=CX11*COD(3)+CZ11*SID3
29328 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29329 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29330 & COD(1),COF(3),SID3,CX11,CZ11
29331 CALL PHO_PREVNT(-1)
29332 ENDIF
29333
29334 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29335 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29336 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29337 COD(2)=CX22*COD(3)+CZ22*SID3
29338 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29339 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29340 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29341
29342 END
29343
29344*$ CREATE PHO_DFMASS.FOR
29345*COPY PHO_DFMASS
29346CDECK ID>, PHO_DFMASS
29347 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29348C**********************************************************************
29349C
29350C sampling of Mx diffractive mass distribution within
29351C limits XMIN, XMAX
29352C
29353C input: XMIN,XMAX mass limitations (GeV)
29354C PREF2 original particle mass/ reference mass
29355C (squared, GeV**2)
29356C PVIRT2 particle virtuality
29357C IMODE M**2 mass distribution
29358C 1 1/(M**2+Q**2)
29359C 2 1/(M**2+Q**2)**alpha
29360C -1 1/(M**2-Mref**2+Q**2)
29361C -2 1/(M**2-Mref**2+Q**2)**alpha
29362C
29363C output: diffractive mass (GeV)
29364C
29365C**********************************************************************
29366 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29367 SAVE
29368
29369 PARAMETER(EPS = 1.D-10)
29370
29371C input/output channels
29372 INTEGER LI,LO
29373 COMMON /POINOU/ LI,LO
29374C event debugging information
29375 INTEGER NMAXD
29376 PARAMETER (NMAXD=100)
29377 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29378 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29379 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29380 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29381C model switches and parameters
29382 CHARACTER*8 MDLNA
29383 INTEGER ISWMDL,IPAMDL
29384 DOUBLE PRECISION PARMDL
29385 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29386C some constants
29387 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29388 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29389 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29390
29391 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29392 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29393 & 'invalid mass limits',XMIN,XMAX,PREF2
29394 CALL PHO_PREVNT(-1)
29395 PHO_DFMASS = 0.135D0
29396 RETURN
29397 ENDIF
29398
29399 IF(IMODE.GT.0) THEN
29400 PM2 = -PVIRT2
29401 ELSE
29402 PM2 = PREF2 - PVIRT2
29403 ENDIF
29404
29405C critical pomeron
29406 IF(ABS(IMODE).EQ.1) THEN
29407 XMIN2 = LOG(XMIN**2-PM2)
29408 XMAX2 = LOG(XMAX**2-PM2)
29409 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29410 XMA2 = EXP(XI)+PM2
29411
29412C supercritical pomeron
29413 ELSE IF(ABS(IMODE).EQ.2) THEN
29414 DDELTA = 1.D0-PARMDL(48)
29415 XMIN2 = (XMIN**2-PM2)**DDELTA
29416 XMAX2 = (XMAX**2-PM2)**DDELTA
29417 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29418 XMA2 = XI**(1.D0/DDELTA)+PM2
29419 ELSE
29420 WRITE(LO,'(/,1X,A,I3)')
29421 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29422 CALL PHO_ABORT
29423 ENDIF
29424
29425 PHO_DFMASS = SQRT(XMA2)
29426C debug output
29427 IF(IDEB(43).GE.15) THEN
29428 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29429 & XMIN,XMAX,PREF2,SQRT(XMA2)
29430 ENDIF
29431
29432 END
29433
29434*$ CREATE PHO_DIFSLP.FOR
29435*COPY PHO_DIFSLP
29436CDECK ID>, PHO_DIFSLP
29437 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29438 & TT,SLWGHT,IREJ)
29439C**********************************************************************
29440C
29441C sampling of T (Mandelstam variable) distribution within
29442C certain limits TMIN, TMAX
29443C
29444C input: IDF1,2 type of diffractive vertex
29445C 0 elastic/quasi-elastic scattering
29446C 1 diffraction dissociation
29447C IVEC1,2 vector meson IDs in case of quasi-elastic
29448C scattering, otherwise 0
29449C XM1 mass of diffractive system 1 (GeV)
29450C XM2 mass of diffractive system 2 (GeV)
29451C XMX max. mass of diffractive system (GeV)
29452C
29453C output: TT squared momentum transfer ( < 0, GeV**2)
29454C SLWGHT weight to allow for mass-dependent slope
29455C IREJ 0 successful sampling
29456C 1 masses too big for given T range
29457C
29458C**********************************************************************
29459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29460 SAVE
29461
29462 PARAMETER(EPS = 1.D-10)
29463
29464C input/output channels
29465 INTEGER LI,LO
29466 COMMON /POINOU/ LI,LO
29467C event debugging information
29468 INTEGER NMAXD
29469 PARAMETER (NMAXD=100)
29470 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29471 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29472 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29473 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29474C model switches and parameters
29475 CHARACTER*8 MDLNA
29476 INTEGER ISWMDL,IPAMDL
29477 DOUBLE PRECISION PARMDL
29478 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29479C internal rejection counters
29480 INTEGER NMXJ
29481 PARAMETER (NMXJ=60)
29482 CHARACTER*10 REJTIT
29483 INTEGER IFAIL
29484 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29485C c.m. kinematics of diffraction
29486 INTEGER NPOSD
29487 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29488 & SIDD,CODD,SIFD,COFD,PDCMS
29489 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29490 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29491C cross sections
29492 INTEGER IPFIL,IFAFIL,IFBFIL
29493 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29494 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29495 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29496 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29497 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29498 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29499 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29500 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29501 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29502 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29503 & IPFIL,IFAFIL,IFBFIL
29504C Reggeon phenomenology parameters
29505 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29506 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29507 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29508 & ALREG,ALREGP,GR(2),B0REG(2),
29509 & GPPP,GPPR,B0PPP,B0PPR,
29510 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29511C parameters of 2x2 channel model
29512 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29513 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29514C parameters of the "simple" Vector Dominance Model
29515 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29516 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29517C some constants
29518 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29519 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29520 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29521
29522 IREJ = 0
29523 XM12 = XM1**2
29524 XM22 = XM2**2
29525 SS = ECMD**2
29526C
29527C range of momentum transfer t
29528 TMIN = -PARMDL(68)
29529 TMAX = -PARMDL(69)
29530C determine min. abs(t) necessary to produce masses
29531 PCM2 = PCMD**2
29532 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29533 IF(PCMP2.LE.0.D0) THEN
29534 IREJ = 1
29535 TT = 0.D0
29536 RETURN
29537 ENDIF
29538 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29539 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29540C
29541 IF(TMINP.LT.TMAX) THEN
29542 IF(IDEB(44).GE.3) THEN
29543 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29544 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29545 & XM1,XM2,TMIN,TMAX,TMINP
29546 ENDIF
29547 IFAIL(32) = IFAIL(32)+1
29548 IREJ = 1
29549 TT = 0.D0
29550 RETURN
29551 ENDIF
29552 TMINA = MIN(TMIN,TMINP)
29553C
29554C calculation of slope (mass-dependent parametrization)
29555 IF(IDF1+IDF2.GT.0) THEN
29556C diffraction dissociation
29557 XMP12 = XM1**2+PVIRTD(1)
29558 XMP22 = XM2**2+PVIRTD(2)
29559 XMX1 = SQRT(XMP12)
29560 XMX2 = SQRT(XMP22)
29561 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29562 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29563 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29564 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29565 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29566 SLOPE = MAX(SLOPE,1.D0)
29567C
29568 XMA1 = XMX
29569 XMA2 = XMX
29570 IF(IDF1.EQ.0) THEN
29571 XMA1 = XM1
29572 ELSE IF(IDF1.EQ.0) THEN
29573 XMA2 = XM2
29574 ENDIF
29575 XMP12 = XMA1**2+PVIRTD(1)
29576 XMP22 = XMA2**2+PVIRTD(2)
29577 XMX1 = SQRT(XMP12)
29578 XMX2 = SQRT(XMP22)
29579 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29580 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29581 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29582 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29583 SLMIN = MAX(SLMIN,1.D0)
29584 ELSE
29585C elastic/quasi-elastic scattering
29586 IF(ISWMDL(13).EQ.0) THEN
29587C external slope values
ecf67adb 29588 WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
9aaba0d6 29589 CALL PHO_ABORT
29590 ELSE IF(ISWMDL(13).EQ.1) THEN
29591C model slopes
29592 IF(IVEC1*IVEC2.EQ.0) THEN
29593 SLOPE = SLOEL
29594 ELSE
29595 SLOPE = SLOVM(IVEC1,IVEC2)
29596 ENDIF
29597 SLMIN = SLOPE
29598 ELSE
29599 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29600 & ISWMDL(13)
29601 CALL PHO_ABORT
29602 ENDIF
29603 ENDIF
29604C
29605C determine max. abs(t) to avoid underflows
29606 TMAXP = -25.D0/SLOPE
29607 TMAXA = MAX(TMAX,TMAXP)
29608C
29609 IF(TMINA.LT.TMAXA) THEN
29610 IF(IDEB(44).GE.3) THEN
29611 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29612 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29613 & XM1,XM2,TMINA,TMAXA,SLOPE
29614 ENDIF
29615 IFAIL(32) = IFAIL(32)+1
29616 IREJ = 1
29617 TT = 0.D0
29618 RETURN
29619 ENDIF
29620C
29621C sampling from corrected range of T
29622 TMINE = EXP(SLMIN*TMINA)
29623 TMAXE = EXP(SLMIN*TMAXA)
29624 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29625 TT = LOG(XI)/SLMIN
29626 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29627C
29628C debug output
29629 IF(IDEB(44).GE.15) THEN
29630 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29631 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29632 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29633 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29634 ENDIF
29635 END
29636
29637*$ CREATE PHO_DIFKIN.FOR
29638*COPY PHO_DIFKIN
29639CDECK ID>, PHO_DIFKIN
29640 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29641C**********************************************************************
29642C
29643C calculation of diffractive kinematics
29644C
29645C input: XMP1 mass of outgoing particle system 1 (GeV)
29646C XMP2 mass of outgoing particle system 2 (GeV)
29647C TT momentum transfer (GeV**2, negative)
29648C
29649C output: PMOM1(5) four momentum of outgoing system 1
29650C PMOM2(5) four momentum of outgoing system 2
29651C IREJ 0 kinematics consistent
29652C 1 kinematics inconsistent
29653C
29654C**********************************************************************
29655 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29656 SAVE
29657
29658 PARAMETER(EPS = 1.D-10,
29659 & DEPS = 0.001)
29660
29661C input/output channels
29662 INTEGER LI,LO
29663 COMMON /POINOU/ LI,LO
29664C event debugging information
29665 INTEGER NMAXD
29666 PARAMETER (NMAXD=100)
29667 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29668 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29669 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29670 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29671C c.m. kinematics of diffraction
29672 INTEGER NPOSD
29673 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29674 & SIDD,CODD,SIFD,COFD,PDCMS
29675 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29676 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29677C some constants
29678 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29679 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29680 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29681
29682 DOUBLE PRECISION PMOM1,PMOM2
29683 DIMENSION PMOM1(5),PMOM2(5)
29684
29685C debug output
29686 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29687 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29688 & ECMD,PCMD,XMP1,XMP2,TT
29689
29690C general kinematic constraints
29691 IREJ = 1
29692 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29693
29694C new squared cms momentum
29695 XMP12 = XMP1**2
29696 XMP22 = XMP2**2
29697 SS = ECMD**2
29698 PCM2 = PCMD**2
29699 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29700
29701C new longitudinal/transverse momentum
29702 E1I = SQRT(PCM2+PMASSD(1)**2)
29703 E1F = SQRT(PCMP2+XMP12)
29704 E2F = SQRT(PCMP2+XMP22)
29705 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29706 PTRAN = PCMP2-PLONG**2
29707
29708C check consistency of kinematics
29709 IF(PTRAN.LT.0.D0) THEN
29710 IF(IDEB(49).GE.1) THEN
29711 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29712 & 'inconsistent kinematics in event call: ',KEVENT
29713 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29714 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29715 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29716 ENDIF
29717 IREJ = 1
29718 RETURN
29719 ELSE
29720 PTRAN = SQRT(PTRAN)
29721 ENDIF
29722 XI = PI2*DT_RNDM(PTRAN)
29723
29724C outgoing momenta in cm. system
29725 PMOM1(4) = E1F
29726 PMOM1(1) = PTRAN*COS(XI)
29727 PMOM1(2) = PTRAN*SIN(XI)
29728 PMOM1(3) = PLONG
29729 PMOM1(5) = XMP1
29730
29731 PMOM2(4) = E2F
29732 PMOM2(1) = -PMOM1(1)
29733 PMOM2(2) = -PMOM1(2)
29734 PMOM2(3) = -PLONG
29735 PMOM2(5) = XMP2
29736 IREJ = 0
29737
29738C debug output / precision check
29739 IF(IDEB(49).GE.0) THEN
29740C check kinematics
29741 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29742 & -PMOM1(1)**2-PMOM1(2)**2
29743 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29744 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29745 & -PMOM2(1)**2-PMOM2(2)**2
29746 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29747 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29748 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29749 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29750 & XMP1,XM1,XMP2,XM2
29751 CALL PHO_PREVNT(-1)
29752 ENDIF
29753C output
29754 IF(IDEB(49).GT.10) THEN
29755 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29756 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
29757 ENDIF
29758 ENDIF
29759
29760 END
29761
29762*$ CREATE PHO_VECRES.FOR
29763*COPY PHO_VECRES
29764CDECK ID>, PHO_VECRES
29765 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29766C**********************************************************************
29767C
29768C sampling of vector meson resonance in diffractive processes
29769C (nothing done for hadrons)
29770C
29771C input: /POSVDM/ VDMFAC factors
29772C
29773C output: IVEC 0 incoming hadron
29774C 1 rho 0
29775C 2 omega
29776C 3 phi
29777C 4 pi+/pi- background
29778C RMASS mass of vector meson (GeV)
29779C IDPDG particle ID according to PDG
29780C IDBAM particle ID according to CPC
29781C
29782C**********************************************************************
29783 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29784 SAVE
29785
29786 PARAMETER(EPS = 1.D-10)
29787
29788C input/output channels
29789 INTEGER LI,LO
29790 COMMON /POINOU/ LI,LO
29791C event debugging information
29792 INTEGER NMAXD
29793 PARAMETER (NMAXD=100)
29794 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29795 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29796 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29797 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29798C nucleon-nucleus / nucleus-nucleus interface to DPMJET
29799 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29800 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29801 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29802 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29803C parameters of the "simple" Vector Dominance Model
29804 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29805 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29806C some constants
29807 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29808 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29809 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29810
29811C particle code translation
29812 DIMENSION ITRANS(4)
29813C rho0,omega,phi,pi+/pi-
29814 DATA ITRANS /113, 223, 333, 92 /
29815
29816 IDPDO = IDPDG
29817C
29818C vector meson production
29819 IF(IDPDG.EQ.22) THEN
29820 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29821 SUM = 0.D0
29822 DO 55 K=1,4
29823 SUM = SUM + VMFA(K)
29824 IF(XI.LE.SUM) GOTO 65
29825 55 CONTINUE
29826 65 CONTINUE
29827C
29828 IDPDG = ITRANS(K)
29829 IDBAM = ipho_pdg2id(IDPDG)
29830 IVEC = K
29831C sample mass of vector meson
29832 CALL PHO_SAMASS(IDPDG,RMASS)
29833
29834C hadronic resonance of multi-pomeron coupling
29835 ELSE IF(IDPDG.EQ.990) THEN
29836 K = 4
29837 IDPDG = 91
29838 IDBAM = ipho_pdg2id(IDPDG)
29839 IVEC = 4
29840C sample mass of two-pion system
29841 CALL PHO_SAMASS(IDPDG,RMASS)
29842
29843C hadron remnants in inucleus interactions
29844 ELSE IF(IDPDG.EQ.81) THEN
29845 IF(IHFLD(1,1).EQ.0) THEN
29846 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29847 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29848 ELSE
29849 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29850 ENDIF
29851 RMAS1 = PHO_PMASS(IDBA1,0)
29852 RMAS2 = PHO_PMASS(IDBA2,0)
29853 IF((IDBA2.NE.0).AND.
29854 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29855 IDBAM = IDBA2
29856 RMASS = RMAS2
29857 ELSE
29858 IDBAM = IDBA1
29859 RMASS = RMAS1
29860 ENDIF
29861 IDPDG = IPHO_ID2PDG(IDBAM)
29862 IVEC = 0
29863 ELSE IF(IDPDG.EQ.82) THEN
29864 IF(IHFLD(2,1).EQ.0) THEN
29865 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29866 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29867 ELSE
29868 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29869 ENDIF
29870 RMAS1 = PHO_PMASS(IDBA1,0)
29871 RMAS2 = PHO_PMASS(IDBA2,0)
29872 IF((IDBA2.NE.0).AND.
29873 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29874 IDBAM = IDBA2
29875 RMASS = RMAS2
29876 ELSE
29877 IDBAM = IDBA1
29878 RMASS = RMAS1
29879 ENDIF
29880 IDPDG = IPHO_ID2PDG(IDBAM)
29881 IVEC = 0
29882 ENDIF
29883C debug output
29884 IF(IDEB(47).GE.5) THEN
29885 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29886 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29887 & IDPDO,IDPDG,IDBAM,RMASS
29888 ENDIF
29889
29890 END
29891
29892*$ CREATE PHO_DIFRES.FOR
29893*COPY PHO_DIFRES
29894CDECK ID>, PHO_DIFRES
29895 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29896 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29897C**********************************************************************
29898C
29899C list of resonance states for low mass resonances
29900C
29901C input: IDMOTH PDG ID of mother particle
29902C IVAL1,2 quarks (photon only)
29903C
29904C output: IDPDG list of PDG IDs for possible resonances
29905C IDBAM list of corresponding CPC IDs
29906C RMASS mass
29907C RGAMS decay width
29908C RMASS additional weight factor
29909C LISTL entries in current list
29910C
29911C**********************************************************************
29912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29913 SAVE
29914
29915 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29916
29917 PARAMETER (EPS = 1.D-10,
29918 & DEPS = 1.D-15)
29919
29920C input/output channels
29921 INTEGER LI,LO
29922 COMMON /POINOU/ LI,LO
29923C event debugging information
29924 INTEGER NMAXD
29925 PARAMETER (NMAXD=100)
29926 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29927 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29928 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29929 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29930C particle ID translation table
29931 integer ID_pdg_list,ID_list,ID_pdg_max
29932 character*12 name_list
29933 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29934 & ID_pdg_max
29935C general particle data
29936 double precision xm_list,tau_list,gam_list,
29937 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29938 & xm_bb82_list,xm_bb102_list
29939 integer ich3_list,iba3_list,iq_list,
29940 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29941 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29942 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29943 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29944 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29945 & ich3_list(300),iba3_list(300),iq_list(3,300),
29946 & id_psm_list(6,6),id_vem_list(6,6),
29947 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29948
29949 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29950 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29951 & 12212, 42212, -12212, -42212,
29952 & 8*0 /
29953 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29954 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29955 & 8*1.D0 /
29956
29957 DATA init /0/
29958
29959C initialize table
29960 if(init.eq.0) then
29961 do i=1,20
29962 if(IRPDG(i).ne.0) then
29963 IRBAM(i) = ipho_pdg2id(IRPDG(i))
29964 endif
29965 enddo
29966 init = 1
29967 endif
29968
29969C copy table with particles and isospin weights
29970 LISTL = 0
29971 IF(IDMOTH.EQ.22) THEN
29972 I1 = 4
29973 I2 = 8
29974 ELSE IF(IDMOTH.EQ.2212) THEN
29975 I1 = 9
29976 I2 = 10
29977 ELSE IF(IDMOTH.EQ.-2212) THEN
29978 I1 = 11
29979 I2 = 12
29980 ELSE
29981 RETURN
29982 ENDIF
29983
29984 DO 100 I=I1,I2
29985 LISTL = LISTL+1
29986 IDBAM(LISTL) = IRBAM(I)
29987 IDPDG(LISTL) = IRPDG(I)
29988 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
29989 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
29990 RWG(LISTL) = RWGHT(I)
29991 100 CONTINUE
29992
29993C debug output
29994 IF(IDEB(85).GE.20) THEN
29995 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
29996 & IVAL1,IVAL2
29997 DO 200 I=1,LISTL
29998 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
29999 200 CONTINUE
30000 ENDIF
30001
30002 END
30003
30004*$ CREATE PHO_MASSAD.FOR
30005*COPY PHO_MASSAD
30006CDECK ID>, PHO_MASSAD
30007 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30008 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30009C***********************************************************************
30010C
30011C fine-correction of low mass strings to mass of corresponding
30012C resonance or two particle threshold
30013C
30014C input: IFLMO PDG ID of mother particle
30015C IFL1,2 requested parton flavours
30016C (not used at the moment)
30017C PMASS reference mass (mass of mother particle)
30018C XMCON conjecture of mass
30019C
30020C output: XMOUT output mass (adjusted input mass)
30021C moved ot nearest mass possible
30022C IDPDG PDG resonance ID
30023C IDcpc CPC resonance ID
30024C
30025C**********************************************************************
30026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30027 SAVE
30028
30029 PARAMETER ( DEPS = 1.D-8 )
30030
30031C input/output channels
30032 INTEGER LI,LO
30033 COMMON /POINOU/ LI,LO
30034C event debugging information
30035 INTEGER NMAXD
30036 PARAMETER (NMAXD=100)
30037 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30038 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30039 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30040 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30041C model switches and parameters
30042 CHARACTER*8 MDLNA
30043 INTEGER ISWMDL,IPAMDL
30044 DOUBLE PRECISION PARMDL
30045 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30046C general particle data
30047 double precision xm_list,tau_list,gam_list,
30048 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30049 & xm_bb82_list,xm_bb102_list
30050 integer ich3_list,iba3_list,iq_list,
30051 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30052 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30053 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30054 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30055 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30056 & ich3_list(300),iba3_list(300),iq_list(3,300),
30057 & id_psm_list(6,6),id_vem_list(6,6),
30058 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30059C particle decay data
30060 double precision wg_sec_list
30061 integer idec_list,isec_list
30062 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30063 & isec_list(3,500)
30064
30065 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30066
30067 XMINP = XMCON
30068 IDPDG = 0
30069 IDcpc = 0
30070 XMOUT = XMINP
30071
30072C resonance treatment activated?
30073 IF(ISWMDL(23).EQ.0) RETURN
30074
30075 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30076 IF(LISTL.LT.1) THEN
30077 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30078 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30079 & IFLMO,IFL1,IFL2
30080 GOTO 50
30081 ENDIF
30082C mass small?
30083 PMASSL = (PMASS+0.15D0)**2
30084 XMINP2 = XMINP**2
30085C determine resonance probability
30086 DM2 = 1.1D0
30087 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30088 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30089C sample new resonance
30090 XWGSUM = 0.D0
30091 DO 100 I=1,LISTL
30092 XWG(I) = RWG(I)/RMA(I)**2
30093 XWGSUM = XWGSUM+XWG(I)
30094 100 CONTINUE
30095
30096 ITER = 0
30097 150 CONTINUE
30098 ITER = ITER+1
30099 IF(ITER.GE.5) THEN
30100 IDcpc = 0
30101 IDPDG = 0
30102 XMOUT = XMINP
30103 GOTO 50
30104 ENDIF
30105
30106 I = 0
30107 XI = XWGSUM*DT_RNDM(XMOUT)
30108 200 CONTINUE
30109 I = I+1
30110 XWGSUM = XWGSUM-XWG(I)
30111 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30112 IDPDG = IRPDG(I)
30113 IDcpc = IRBAM(I)
30114 GARES = RGA(I)
30115 XMRES = RMA(I)
30116 XMRES2 = XMRES**2
30117C sample new mass (from Breit-Wigner cross section)
30118 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30119 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30120 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30121 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30122 XMOUT = SQRT(XMOUT)
30123
30124C check mass for decay
30125 AMDCY = 2.D0*XMRES
30126 ID = abs(IDcpc)
30127 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30128 AMSUM = 0.D0
30129 DO 275 I=1,3
30130 IF(isec_list(I,IK).NE.0)
30131 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30132 275 CONTINUE
30133 AMDCY = MIN(AMDCY,AMSUM)
30134 250 CONTINUE
30135 IF(AMDCY.GE.XMOUT) GOTO 150
30136
30137C debug output
30138 IF(IDEB(7).GE.10)
30139 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30140 & 'PHO_MASSAD: ',
30141 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30142 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30143 RETURN
30144 ENDIF
30145
30146 50 CONTINUE
30147C debug output
30148 IF(IDEB(7).GE.15)
30149 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30150 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30151 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30152
30153 END
30154
30155*$ CREATE PHO_PDF.FOR
30156*COPY PHO_PDF
30157CDECK ID>, PHO_PDF
30158 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30159C***************************************************************
30160C
30161C call different PDF sets for different particle types
30162C
30163C input: NPAR 1 IGRP(1),ISET(1)
30164C 2 IGRP(2),ISET(2)
30165C X momentum fraction
30166C SCALE2 squared scale (GeV**2)
30167C P2VIR particle virtuality (positive, GeV**2)
30168C
30169C output PD(-6:6) field containing the x*PDF fractions
30170C
30171C***************************************************************
30172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30173 SAVE
30174
30175 DIMENSION PD(-6:6)
30176
30177C input/output channels
30178 INTEGER LI,LO
30179 COMMON /POINOU/ LI,LO
30180C currently activated parton density parametrizations
30181 CHARACTER*8 PDFNAM
30182 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30183 DOUBLE PRECISION PDFLAM,PDFQ2M
30184 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30185 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30186C event debugging information
30187 INTEGER NMAXD
30188 PARAMETER (NMAXD=100)
30189 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30190 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30191 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30192 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30193C model switches and parameters
30194 CHARACTER*8 MDLNA
30195 INTEGER ISWMDL,IPAMDL
30196 DOUBLE PRECISION PARMDL
30197 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30198
30199 DIMENSION PARAM(20),VALUE(20)
30200 CHARACTER*20 PARAM
30201
30202 REAL XR,P2R,Q2R,F2GM,XPDFGM
30203 DIMENSION XPDFGM(-6:6)
30204
30205C check of kinematic boundaries
30206 XI = X
30207 IF(X.GT.1.D0) THEN
30208 IF(IDEB(37).GE.0) THEN
30209 WRITE(LO,'(/,1X,A,E15.8/)')
30210 & 'PHO_PDF: x>1 (corrected to x=1)',X
30211 CALL PHO_PREVNT(-1)
30212 ENDIF
30213 XI = 0.99999999999D0
30214 ELSE IF(X.LE.0.D0) THEN
30215 IF(IDEB(37).GE.0) THEN
30216 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30217 CALL PHO_PREVNT(-1)
30218 ENDIF
30219 XI = 0.0001D0
30220 ENDIF
30221
30222 DO 100 I=-6,6
30223 PD(I) = 0.D0
30224 100 CONTINUE
30225 IRET = 1
30226
30227 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30228
30229C internal PDFs
30230
30231 IF(IEXT(NPAR).EQ.0) THEN
30232 IF(ITYPE(NPAR).EQ.1) THEN
30233C proton PDFs
30234 IF(IGRP(NPAR).EQ.5) THEN
30235 IF(ISET(NPAR).EQ.3) THEN
30236 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30237 UV = UDV-DV
30238 UDB = 2.D0*UDB
30239 DEL = 0.D0
30240 IRET = 0
30241 ELSE IF(ISET(NPAR).EQ.4) THEN
30242 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30243 UV = UDV-DV
30244 UDB = 2.D0*UDB
30245 DEL = 0.D0
30246 IRET = 0
30247 ELSE IF(ISET(NPAR).EQ.5) THEN
30248 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30249C heavy quarks from GRV92-HO
30250 AMU2 = 0.3
30251 ALAM2 = 0.248 * 0.248
30252 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30253 SC = 0.820
30254 ALC = 0.98
30255 BEC = 0.0
30256 AKC = -0.625 - 0.523 * S
30257 AGC = 0.0
30258 BC = 1.896 + 1.616 * S
30259 DC = 4.12 + 0.683 * S
30260 EC = 4.36 + 1.328 * S
30261 ESC = 0.677 + 0.679 * S
30262 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30263 SBO = 1.297
30264 ALB = 0.99
30265 BEB = 0.0
30266 AKB = 0.0 - 0.193 * S
30267 AGB = 0.0
30268 BBO = 0.0
30269 DB = 3.447 + 0.927 * S
30270 EB = 4.68 + 1.259 * S
30271 ESB = 1.892 + 2.199 * S
30272 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30273 IRET = 0
30274 ELSE IF(ISET(NPAR).EQ.6) THEN
30275 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30276C heavy quarks from GRV92-LO
30277 AMU2 = 0.25
30278 ALAM2 = 0.232D0**2
30279 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30280 SC = 0.888
30281 ALC = 1.01
30282 BEC = 0.37
30283 AKC = 0.0
30284 AGC = 0.0
30285 BC = 4.24 - 0.804 * S
30286 DC = 3.46 + 1.076 * S
30287 EC = 4.61 + 1.490 * S
30288 ESC = 2.555 + 1.961 * S
30289 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30290 SBO = 1.351
30291 ALB = 1.00
30292 BEB = 0.51
30293 AKB = 0.0
30294 AGB = 0.0
30295 BBO = 1.848
30296 DB = 2.929 + 1.396 * S
30297 EB = 4.71 + 1.514 * S
30298 ESB = 4.02 + 1.239 * S
30299 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30300 IRET = 0
30301 ELSE IF(ISET(NPAR).EQ.7) THEN
30302 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30303C heavy quarks from GRV92-HO
30304 AMU2 = 0.3
30305 ALAM2 = 0.248 * 0.248
30306 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30307 SC = 0.820
30308 ALC = 0.98
30309 BEC = 0.0
30310 AKC = -0.625 - 0.523 * S
30311 AGC = 0.0
30312 BC = 1.896 + 1.616 * S
30313 DC = 4.12 + 0.683 * S
30314 EC = 4.36 + 1.328 * S
30315 ESC = 0.677 + 0.679 * S
30316 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30317 SBO = 1.297
30318 ALB = 0.99
30319 BEB = 0.0
30320 AKB = 0.0 - 0.193 * S
30321 AGB = 0.0
30322 BBO = 0.0
30323 DB = 3.447 + 0.927 * S
30324 EB = 4.68 + 1.259 * S
30325 ESB = 1.892 + 2.199 * S
30326 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30327 IRET = 0
30328 ELSE IF(ISET(NPAR).EQ.8) THEN
30329 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30330 DEL = DS-US
30331 UDB = DS+US
30332C heavy quarks from GRV92-LO
30333 AMU2 = 0.25
30334 ALAM2 = 0.232D0**2
30335 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30336 SC = 0.888
30337 ALC = 1.01
30338 BEC = 0.37
30339 AKC = 0.0
30340 AGC = 0.0
30341 BC = 4.24 - 0.804 * S
30342 DC = 3.46 + 1.076 * S
30343 EC = 4.61 + 1.490 * S
30344 ESC = 2.555 + 1.961 * S
30345 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30346 SBO = 1.351
30347 ALB = 1.00
30348 BEB = 0.51
30349 AKB = 0.0
30350 AGB = 0.0
30351 BBO = 1.848
30352 DB = 2.929 + 1.396 * S
30353 EB = 4.71 + 1.514 * S
30354 ESB = 4.02 + 1.239 * S
30355 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30356 IRET = 0
30357 ELSE IF(ISET(NPAR).EQ.9) THEN
30358* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30359 DEL = DS-US
30360 UDB = DS+US
30361C heavy quarks from GRV92-LO
30362 AMU2 = 0.25
30363 ALAM2 = 0.232D0**2
30364 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30365 SC = 0.888
30366 ALC = 1.01
30367 BEC = 0.37
30368 AKC = 0.0
30369 AGC = 0.0
30370 BC = 4.24 - 0.804 * S
30371 DC = 3.46 + 1.076 * S
30372 EC = 4.61 + 1.490 * S
30373 ESC = 2.555 + 1.961 * S
30374 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30375 SBO = 1.351
30376 ALB = 1.00
30377 BEB = 0.51
30378 AKB = 0.0
30379 AGB = 0.0
30380 BBO = 1.848
30381 DB = 2.929 + 1.396 * S
30382 EB = 4.71 + 1.514 * S
30383 ESB = 4.02 + 1.239 * S
30384 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30385 IRET = 0
30386 ENDIF
30387 PD(-5) = BB
30388 PD(-4) = CB
30389 PD(-3) = SB
30390 PD(-2) = 0.5D0*(UDB-DEL)
30391 PD(-1) = 0.5D0*(UDB+DEL)
30392 PD(0) = GL
30393 PD(1) = DV+PD(-1)
30394 PD(2) = UV+PD(-2)
30395 PD(3) = PD(-3)
30396 PD(4) = PD(-4)
30397 PD(5) = PD(-5)
30398 ENDIF
30399 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30400C pion PDFs (default for pi+)
30401 IF(IGRP(NPAR).EQ.5) THEN
30402 IF(ISET(NPAR).EQ.1) THEN
30403 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30404 IRET = 0
30405 ELSE IF(ISET(NPAR).EQ.2) THEN
30406 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30407 IRET = 0
30408 ENDIF
30409 PD(-5) = BB
30410 PD(-4) = CB
30411 PD(-3) = QB
30412 PD(-2) = QB
30413 PD(-1) = QB+VA
30414 PD(0) = GL
30415 PD(1) = QB
30416 PD(2) = VA+QB
30417 PD(3) = QB
30418 PD(4) = CB
30419 PD(5) = BB
30420 ENDIF
30421 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30422C photon PDFs
30423 IF(IGRP(NPAR).EQ.5) THEN
30424 IF(ISET(NPAR).EQ.1) THEN
30425 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30426 IRET = 0
30427 ELSE IF(ISET(NPAR).EQ.2) THEN
30428 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30429 IRET = 0
30430 ELSE IF(ISET(NPAR).EQ.3) THEN
30431 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30432 IRET = 0
30433 ENDIF
30434C reweight with Drees-Godbole factor
30435 WGX = 1.D0
30436 IF(P2VIR.GT.0.001D0) THEN
30437 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30438 & /LOG(SCALE2/PARMDL(144))
30439 WGX = MAX(WGX,0.D0)
30440 ENDIF
30441 PD(-5) = BB*WGX/137.D0
30442 PD(-4) = CB*WGX/137.D0
30443 PD(-3) = SB*WGX/137.D0
30444 PD(-2) = UB*WGX/137.D0
30445 PD(-1) = DB*WGX/137.D0
30446 PD(0) = GL*WGX*WGX/137.D0
30447 PD(1) = PD(-1)
30448 PD(2) = PD(-2)
30449 PD(3) = PD(-3)
30450 PD(4) = PD(-4)
30451 PD(5) = PD(-5)
30452 ELSE IF(IGRP(NPAR).EQ.8) THEN
30453 IF(ISET(NPAR).EQ.1) THEN
30454 CALL PHO_PHGAL (XI,SCALE2,PD)
30455 IRET = 0
30456 ENDIF
30457 ENDIF
30458 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30459C Pomeron PDFs
30460 MODE = IGRP(NPAR)
30461 IF(MODE.EQ.1) THEN
30462 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30463 IRET = 0
30464 ELSE IF(MODE.EQ.2) THEN
30465 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30466 IRET = 0
30467 ELSE IF(MODE.EQ.3) THEN
30468 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30469 IRET = 0
30470 ELSE IF(MODE.EQ.4) THEN
30471 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30472 DO 105 I=-4,4
30473 PD(I) = PD(I)*PARMDL(78)
30474 105 CONTINUE
30475 IRET = 0
30476 ENDIF
30477 ENDIF
30478
30479C external PDFs
30480
30481 ELSE IF(IEXT(NPAR).EQ.2) THEN
30482C PDFLIB call: new PDF numbering
30483 IF(NPAR.NE.NPAOLD) THEN
30484 PARAM(1) = 'NPTYPE'
30485 PARAM(2) = 'NGROUP'
30486 PARAM(3) = 'NSET'
30487 PARAM(4) = ' '
30488 VALUE(1) = ITYPE(NPAR)
30489 VALUE(2) = ABS(IGRP(NPAR))
30490 VALUE(3) = ISET(NPAR)
30491 CALL PDFSET(PARAM,VALUE)
30492 ENDIF
30493 IF(ITYPE(NPAR).EQ.3) THEN
30494 IP2 = 0
30495 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30496 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30497 ELSE
30498 SCALE = SQRT(SCALE2)
30499 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30500 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30501 ENDIF
30502 DO 115 I=3,6
30503 PD(I) = PD(-I)
30504 115 CONTINUE
30505 IF(ITYPE(NPAR).EQ.1) THEN
30506C proton valence quarks
30507 PD(1) = PD(1)+PD(-1)
30508 PD(2) = PD(2)+PD(-2)
30509 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30510C pi+ valences
30511 DVAL = PD(1)
30512 PD(1) = PD(-1)
30513 PD(-1) = DVAL+PD(1)
30514 PD(2) = PD(2)+PD(-2)
30515 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30516C photon conventions
30517 PD(1) = PD(-1)
30518 PD(2) = PD(-2)
30519 ENDIF
30520 IRET = 0
30521
30522 ELSE IF(IEXT(NPAR).EQ.3) THEN
30523C PHOLIB call: version 2.0
30524 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30525 IF(IRET.LT.0) THEN
30526 WRITE(LO,'(/1X,A,I2)')
30527 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30528 CALL PHO_ABORT
30529 ENDIF
30530 IRET = 0
30531
30532C photon PDFs depending on photon virtuality
30533
30534 ELSE IF(IEXT(NPAR).EQ.4) THEN
30535 IF(IGRP(NPAR).EQ.1) THEN
30536C Schuler/Sjostrand PDF (interface to single precision)
30537 XR = XI
30538 Q2R = SCALE2
30539 P2R = P2VIR
30540 IP2 = 0
30541 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30542 DO 120 I=-6,6
30543 PD(I) = DBLE(XPDFGM(I))
30544 120 CONTINUE
30545 IRET = 0
30546 ELSE IF(IGRP(NPAR).EQ.5) THEN
30547C Gluck/Reya/Stratmann
30548 IF(ISET(NPAR).EQ.4) THEN
30549 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30550 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30551 IRET = 0
30552 PD(-5) = 0.D0
30553 PD(-4) = CB
30554 PD(-3) = SB/137.D0
30555 PD(-2) = UB/137.D0
30556 PD(-1) = DB/137.D0
30557 PD(0) = GL/137.D0
30558 PD(1) = PD(-1)
30559 PD(1) = PD(-1)
30560 PD(2) = PD(-2)
30561 PD(3) = PD(-3)
30562 PD(4) = PD(-4)
30563 PD(5) = PD(-5)
30564 ENDIF
30565 ENDIF
30566 ENDIF
30567
30568C check for errors
30569
30570 IF(IRET.NE.0) THEN
30571 WRITE(LO,'(/1X,A,/10X,5I6)')
30572 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30573 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30574 CALL PHO_ABORT
30575 ENDIF
30576C error in NPAR
30577 ELSE
30578 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30579 CALL PHO_ABORT
30580 ENDIF
30581 NPAOLD = NPAR
30582
30583C valence quark treatment
30584
30585 IF(ITYPE(NPAR).EQ.2) THEN
30586C meson conventions
30587 IF(IPARID(NPAR).EQ.111) THEN
30588C pi0 valence quarks
30589 PD(-1) = (PD(1)+PD(-1))/2.D0
30590 PD(1) = PD(-1)
30591 PD(-2) = (PD(2)+PD(-2))/2.D0
30592 PD(2) = PD(-2)
30593 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30594C K+/-
30595 VALS = PD(-1)-PD(1)
30596 PD(-1) = PD(1)
30597 PD(-3) = PD(-3)+VALS
30598 ELSE IF( (IPARID(NPAR).EQ.311)
30599 & .OR.(IPARID(NPAR).EQ.310)
30600 & .OR.(IPARID(NPAR).EQ.130)) THEN
30601C neutral kaons
30602 VALS = PD(-1)-PD(1)
30603 VALU = PD(2)-PD(-2)
30604 PD(-1) = PD(1)
30605 PD(2) = PD(-2)
30606 PD(2) = PD(2)+VALU/2.D0
30607 PD(-2) = PD(-2)+VALU/2.D0
30608 PD(3) = PD(3)+VALS/2.D0
30609 PD(-3) = PD(-3)+VALS/2.D0
30610 ENDIF
30611 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30612C nucleon conventions
30613 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30614C neutron valence quarks
30615 DUM = PD(1)
30616 PD(1) = PD(2)
30617 PD(2) = DUM
30618 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30619C (anti-)sigma+
30620 VALS = PD(1)-PD(-1)
30621 PD(1) = PD(-1)
30622 PD(3) = PD(3)+VALS
30623 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30624C (anti-)sigma-
30625 VALS = PD(1)-PD(-1)
30626 VALD = PD(2)-PD(-2)
30627 PD(1) = PD(-1)
30628 PD(2) = PD(-2)
30629 PD(1) = PD(1)+VALD
30630 PD(3) = PD(3)+VALS
30631 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30632 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30633C (anti-)sigma0 and (anti-)lambda
30634 VALS = PD(1)-PD(-1)
30635 VALD = (PD(2)-PD(-2))/2.D0
30636 PD(1) = PD(-1)
30637 PD(2) = PD(-2)
30638 PD(1) = PD(1)+VALD
30639 PD(2) = PD(2)+VALD
30640 PD(3) = PD(3)+VALS
30641 ENDIF
30642 ENDIF
30643
30644C antiparticle
30645 IF(IPARID(NPAR).LT.0) THEN
30646 DO 190 I=1,4
30647 DUM=PD(I)
30648 PD(I)=PD(-I)
30649 PD(-I)=DUM
30650 190 CONTINUE
30651 ENDIF
30652
30653C optionally remove valence quarks
30654 IF(IPAVA(NPAR).EQ.0) THEN
30655 DO 200 I=1,4
30656 PD(I) = MIN(PD(-I),PD(I))
30657 PD(-I) = PD(I)
30658 200 CONTINUE
30659 ENDIF
30660
30661C debug information
30662 IF(IDEB(37).GE.30) WRITE(LO,
30663 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30664 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30665 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30666 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30667
30668 END
30669
30670*$ CREATE PHO_QPMPDF.FOR
30671*COPY PHO_QPMPDF
30672CDECK ID>, PHO_QPMPDF
30673 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30674C***************************************************************
30675C
30676C contribution to photon PDF from box graph
30677C (Bethe-Heitler process)
30678C
30679C input: IQ quark flavour
30680C SCALE2 scale (GeV**2, positive)
30681C PTREF reference scale (GeV, positive)
30682C X parton momentum fraction
30683C PVIRT photon virtuality (GeV**2, positive)
30684C FXP x*f(x,Q**2), x times parton density
30685C
30686C***************************************************************
30687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30688 SAVE
30689
30690C input/output channels
30691 INTEGER LI,LO
30692 COMMON /POINOU/ LI,LO
30693C event debugging information
30694 INTEGER NMAXD
30695 PARAMETER (NMAXD=100)
30696 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30697 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30698 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30699 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30700C internal rejection counters
30701 INTEGER NMXJ
30702 PARAMETER (NMXJ=60)
30703 CHARACTER*10 REJTIT
30704 INTEGER IFAIL
30705 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30706C some constants
30707 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30708 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30709 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30710
30711 DIMENSION QM(6)
30712 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30713
30714 FXP = 0.D0
30715 I = ABS(IQ)
30716C
30717* QM2 = MAX(QM(I),PTREF)**2
30718* QM2 = MAX(QM2,PVIRT)
30719* BBE = (1.D0-X)*SCALE2
30720* IF(BBE.LE.0.D0) THEN
30721* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30722* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30723* & PVIRT,QM(I)
30724* ENDIF
30725* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30726* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30727C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30728 QM2 = MAX(QM(I),PTREF)**2
30729 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30730 IF(W2.GT.4.D0*QM2) THEN
30731 BE = SQRT(1.D0-4.D0*QM2/W2)
30732 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30733 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30734* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30735 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30736 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30737 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30738 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30739 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30740 ELSE
30741 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30742 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30743 & PVIRT,QM(I)
30744 ENDIF
30745C debug output
30746 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30747 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30748 END
30749
30750*$ CREATE PHO_SETPDF.FOR
30751*COPY PHO_SETPDF
30752CDECK ID>, PHO_SETPDF
30753 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30754C***************************************************************
30755C
30756C assigns PDF numbers to particles
30757C
30758C input: IDPDG PDG number of particle
30759C ITYP particle type
30760C IPAR PDF paramertization
30761C ISET number of set
30762C IEXT library number for PDF calculation
30763C IPAVAL (only output)
30764C 1 PDF with valence quarks
30765C 0 PDF without valence quarks
30766C MODE -1 add entry to table
30767C 1 read from table
30768C 2 output of table
30769C
30770C***************************************************************
30771 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30772 SAVE
30773
30774C input/output channels
30775 INTEGER LI,LO
30776 COMMON /POINOU/ LI,LO
30777C event debugging information
30778 INTEGER NMAXD
30779 PARAMETER (NMAXD=100)
30780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30784C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30785 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30786 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30787 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30788 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30789
30790 DIMENSION IPDFS(5,50)
30791 DATA IENTRY / 0 /
30792
30793 IF(MODE.EQ.1) THEN
30794 I = 1
30795 IF(IDPDG.EQ.81) THEN
30796 IDCMP = IDEQP(1)
30797 IPAVAL = IHFLS(1)
30798 ELSE IF(IDPDG.EQ.82) THEN
30799 IDCMP = IDEQP(2)
30800 IPAVAL = IHFLS(2)
30801 ELSE
30802 IDCMP = IDPDG
30803 IPAVAL = 1
30804 ENDIF
30805200 CONTINUE
30806 IF(IDCMP.EQ.IPDFS(1,I)) THEN
30807 ITYP = IPDFS(2,I)
30808 IPAR = IPDFS(3,I)
30809 ISET = IPDFS(4,I)
30810 IEXT = IPDFS(5,I)
30811 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30812 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30813 RETURN
30814 ENDIF
30815 I = I+1
30816 IF(I.GT.IENTRY) THEN
30817 WRITE(LO,'(/1X,A,I7)')
30818 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
30819 CALL PHO_ABORT
30820 ENDIF
30821 GOTO 200
30822 ELSE IF(MODE.EQ.-1) THEN
30823 DO 50 I=1,IENTRY
30824 IF(IDPDG.EQ.IPDFS(1,I)) THEN
30825 WRITE(LO,'(/1X,A,5I6)')
30826 & 'PHO_SETPDF: overwrite old particle PDF',
30827 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30828 GOTO 100
30829 ENDIF
30830 50 CONTINUE
30831 I = IENTRY+1
30832 IF(I.GT.50) THEN
30833 WRITE(LO,'(/1X,A,/1x,6I6)')
30834 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
30835 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30836 STOP
30837 ENDIF
30838 IENTRY = I
30839 100 CONTINUE
30840 IPDFS(1,I) = IDPDG
30841 IF(IDPDG.EQ.990) THEN
30842 ITYP1 = 20
30843 ELSE IF(IDPDG.EQ.22) THEN
30844 ITYP1 = 3
30845 ELSE IF(ABS(IDPDG).LT.1000) THEN
30846 ITYP1 = 2
30847 ELSE
30848 ITYP1 = 1
30849 ENDIF
30850 IPDFS(2,I) = ITYP1
30851 IPDFS(3,I) = IPAR
30852 IPDFS(4,I) = ISET
30853 IPDFS(5,I) = IEXT
30854 ELSE IF(MODE.EQ.-2) THEN
30855 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30856 DO 150 I=1,IENTRY
30857 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
30858 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30859 150 CONTINUE
30860 ELSE
30861 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30862 ENDIF
30863 END
30864
30865*$ CREATE PHO_GETPDF.FOR
30866*COPY PHO_GETPDF
30867CDECK ID>, PHO_GETPDF
30868 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30869C***************************************************************
30870C
30871C get PDF information
30872C
30873C input: NPAR 1 first PDF in /POPPDF/
30874C 2 second PDF in /POPPDF/
30875C
30876C output: PDFNA name of PDf parametrization
30877C ALA QCD LAMBDA (4 flavours, in GeV)
30878C Q2MI minimal Q2
30879C Q2MA maximal Q2
30880C XMI minimal X
30881C XMA maximal X
30882C
30883C***************************************************************
30884 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30885 SAVE
30886
30887 CHARACTER*8 PDFNA
30888
30889C input/output channels
30890 INTEGER LI,LO
30891 COMMON /POINOU/ LI,LO
30892
30893C PHOLIB 4.15 common
30894 COMMON /W50512/ QCDL4,QCDL5
30895 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30896
30897C PHOPDF version 2.0 common
30898 PARAMETER (MAXS=6,MAXP=10)
30899 CHARACTER*4 CHPAR
30900 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30901 & NSET(MAXP,2),NFL(MAXP)
30902 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30903
30904C currently activated parton density parametrizations
30905 CHARACTER*8 PDFNAM
30906 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30907 DOUBLE PRECISION PDFLAM,PDFQ2M
30908 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30909 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30910
30911 DIMENSION PARAM(20),VALUE(20)
30912 CHARACTER*20 PARAM
30913
30914 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30915 WRITE(LO,'(/1X,A,I6)')
30916 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30917 CALL PHO_ABORT
30918 ENDIF
30919 ALA = 0.D0
30920
30921 IF(IEXT(NPAR).EQ.0) THEN
30922
30923C internal parametrizations
30924
30925 IF(ITYPE(NPAR).EQ.1) THEN
30926C proton PDFs
30927 IF(IGRP(NPAR).EQ.5) THEN
30928 IF(ISET(NPAR).EQ.3) THEN
30929 ALA = 0.2D0
30930 Q2MI = 0.3D0
30931 PDFNA = 'GRV92 HO'
30932 ELSE IF(ISET(NPAR).EQ.4) THEN
30933 ALA = 0.2D0
30934 Q2MI = 0.25D0
30935 PDFNA = 'GRV92 LO'
30936 ELSE IF(ISET(NPAR).EQ.5) THEN
30937 ALA = 0.2D0
30938 Q2MI = 0.4D0
30939 PDFNA = 'GRV94 HO'
30940 ELSE IF(ISET(NPAR).EQ.6) THEN
30941 ALA = 0.2D0
30942 Q2MI = 0.4D0
30943 PDFNA = 'GRV94 LO'
30944 ELSE IF(ISET(NPAR).EQ.7) THEN
30945 ALA = 0.2D0
30946 Q2MI = 0.4D0
30947 PDFNA = 'GRV94 DI'
30948 ELSE IF(ISET(NPAR).EQ.8) THEN
30949 ALA = 0.175D0
30950 Q2MI = 0.8D0
30951 PDFNA = 'GRV98 LO'
30952 ELSE IF(ISET(NPAR).EQ.9) THEN
30953 ALA = 0.175D0
30954 Q2MI = 0.8D0
30955 PDFNA = 'GRV98 SC'
30956 ENDIF
30957 ENDIF
30958 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30959C pion PDFs
30960 IF(IGRP(NPAR).EQ.5) THEN
30961 IF(ISET(NPAR).EQ.1) THEN
30962 ALA = 0.2D0
30963 Q2MI = 0.3D0
30964 PDFNA = 'GRV-P HO'
30965 ELSE IF(ISET(NPAR).EQ.2) THEN
30966 ALA = 0.2D0
30967 Q2MI = 0.25D0
30968 PDFNA = 'GRV-P LO'
30969 ENDIF
30970 ENDIF
30971 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30972C photon PDFs
30973 IF(IGRP(NPAR).EQ.5) THEN
30974 IF(ISET(NPAR).EQ.1) THEN
30975 ALA = 0.2D0
30976 Q2MI = 0.3D0
30977 PDFNA = 'GRV-G LH'
30978 ELSE IF(ISET(NPAR).EQ.2) THEN
30979 ALA = 0.2D0
30980 Q2MI = 0.3D0
30981 PDFNA = 'GRV-G HO'
30982 ELSE IF(ISET(NPAR).EQ.3) THEN
30983 ALA = 0.2D0
30984 Q2MI = 0.25D0
30985 PDFNA = 'GRV-G LO'
30986 ENDIF
30987 ELSE IF(IGRP(NPAR).EQ.8) THEN
30988 IF(ISET(NPAR).EQ.1) THEN
30989 ALA = 0.2D0
30990 Q2MI = 4.D0
30991 PDFNA = 'AGL-G LO'
30992 ENDIF
30993 ENDIF
30994 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30995C pomeron PDFs
30996 IF(IGRP(NPAR).EQ.4) THEN
30997 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
30998 ELSE
30999 ALA = 0.3D0
31000 Q2MI = 2.D0
31001 PDFNA = 'POM-PDF1'
31002 ENDIF
31003 ENDIF
31004
31005C external parametrizations
31006
31007 ELSE IF(IEXT(NPAR).EQ.1) THEN
31008C PDFLIB call: old numbering
31009 PARAM(1) = 'MODE'
31010 PARAM(2) = ' '
31011 VALUE(1) = IGRP(NPAR)
31012 CALL PDFSET(PARAM,VALUE)
31013 Q2MI = Q2MIN
31014 Q2MA = Q2MAX
31015 XMI = XMIN
31016 XMA = XMAX
31017 ALA = QCDL4
31018 PDFNA = 'PDFLIB1'
31019 ELSE IF(IEXT(NPAR).EQ.2) THEN
31020C PDFLIB call: new numbering
31021 PARAM(1) = 'NPTYPE'
31022 PARAM(2) = 'NGROUP'
31023 PARAM(3) = 'NSET'
31024 PARAM(4) = ' '
31025 VALUE(1) = ITYPE(NPAR)
31026 VALUE(2) = IGRP(NPAR)
31027 VALUE(3) = ISET(NPAR)
31028 CALL PDFSET(PARAM,VALUE)
31029 Q2MI = Q2MIN
31030 Q2MA = Q2MAX
31031 XMI = XMIN
31032 XMA = XMAX
31033 ALA = QCDL4
31034 PDFNA = 'PDFLIB2'
31035 ELSE IF(IEXT(NPAR).EQ.3) THEN
31036C PHOLIB interface
31037 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31038 Q2MI = 2.D0
31039 PDFNA = CHPAR(IGRP(NPAR))
31040
31041C some special internal parametrizations
31042
31043 ELSE IF(IEXT(NPAR).EQ.4) THEN
31044C photon PDFs depending on virtualities
31045 IF(IGRP(NPAR).EQ.1) THEN
31046C Schuler/Sjostrand parametrization
31047 ALA = 0.2D0
31048 IF(ISET(NPAR).EQ.1) THEN
31049 Q2MI = 0.2D0
31050 PDFNA = 'SaS-1D '
31051 ELSE IF(ISET(NPAR).EQ.2) THEN
31052 Q2MI = 0.2D0
31053 PDFNA = 'SaS-1M '
31054 ELSE IF(ISET(NPAR).EQ.3) THEN
31055 Q2MI = 2.D0
31056 PDFNA = 'SaS-2D '
31057 ELSE IF(ISET(NPAR).EQ.4) THEN
31058 Q2MI = 2.D0
31059 PDFNA = 'SaS-2M '
31060 ENDIF
31061 ELSE IF(IGRP(NPAR).EQ.5) THEN
31062C Gluck/Reya/Stratmann parametrization
31063 IF(ISET(NPAR).EQ.4) THEN
31064 ALA = 0.2D0
31065 Q2MI = 0.6D0
31066 PDFNA = 'GRS-G LO'
31067 ENDIF
31068 ENDIF
31069 ELSE IF(IEXT(NPAR).EQ.5) THEN
31070C Schuler/Sjostrand anomalous only
31071 ALA = 0.2D0
31072 Q2MI = 0.2D0
31073 PDFNA = 'SaS anom'
31074 ENDIF
31075 IF(ALA.LT.0.01D0) THEN
31076 WRITE(LO,'(/1X,2A,/10X,5I6)')
31077 & 'PHO_GETPDF:ERROR: ',
31078 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31079 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31080 CALL PHO_ABORT
31081 ENDIF
31082
31083 END
31084
31085*$ CREATE PHO_ACTPDF.FOR
31086*COPY PHO_ACTPDF
31087CDECK ID>, PHO_ACTPDF
31088 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31089C***************************************************************
31090C
31091C activate PDF for QCD calculations
31092C
31093C input: IDPDG PDG particle number
31094C K 1 first PDF in /POPPDF/
31095C 2 second PDF in /POPPDF/
31096C -2 write current settings
31097C
31098C output: /POPPDF/
31099C
31100C***************************************************************
31101 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31102 SAVE
31103
31104C input/output channels
31105 INTEGER LI,LO
31106 COMMON /POINOU/ LI,LO
31107C event debugging information
31108 INTEGER NMAXD
31109 PARAMETER (NMAXD=100)
31110 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31111 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31112 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31113 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31114C currently activated parton density parametrizations
31115 CHARACTER*8 PDFNAM
31116 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31117 DOUBLE PRECISION PDFLAM,PDFQ2M
31118 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31119 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31120
31121 IF(K.GT.0) THEN
31122
31123C read PDF from table
31124 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31125 & IPAVA(K),1)
31126 IPARID(K) = IDPDG
31127C get PDF parameters
31128 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31129C initialize alpha_s calculation
31130 alam2 = PDFLAM(K)*PDFLAM(K)
31131 DUMMY = PHO_ALPHAS(alam2,-K)
31132
31133 IF(IDEB(2).GE.20) THEN
31134 WRITE(LO,'(1X,A)')
31135 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31136 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31137 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31138 & IEXT(K),IPARID(K)
31139 ENDIF
31140 NPAOLD = K
31141
31142 ELSE IF(K.EQ.-2) THEN
31143
31144C write table of current PDFs
31145 WRITE(LO,'(1X,A)')
31146 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31147 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31148 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31149 & IPARID(1)
31150 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31151 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31152 & IPARID(2)
31153
31154 ELSE
31155
31156 WRITE(LO,'(/1X,A,2I4)')
31157 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31158 CALL PHO_ABORT
31159
31160 ENDIF
31161
31162 END
31163
31164*$ CREATE PHO_PDFTST.FOR
31165*COPY PHO_PDFTST
31166CDECK ID>, PHO_PDFTST
31167 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31168C*********************************************************************
31169C
31170C structure function test utility
31171C
31172C input: IDPDG PDG ID of particle
31173C SCALE2 squared scale (GeV**2)
31174C P2MASS particle virtuality (pos, GeV**2)
31175C
31176C output: tables of PDF, sum rule checking, table of F2
31177C
31178C*********************************************************************
31179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31180 SAVE
31181
31182C input/output channels
31183 INTEGER LI,LO
31184 COMMON /POINOU/ LI,LO
31185C currently activated parton density parametrizations
31186 CHARACTER*8 PDFNAM
31187 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31188 DOUBLE PRECISION PDFLAM,PDFQ2M
31189 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31190 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31191C some constants
31192 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31193 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31194 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31195
31196 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31197 CHARACTER*8 PDFNA
31198
31199 CALL PHO_ACTPDF(IDPDG,1)
31200 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31201
31202 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31203 WRITE(LO,'(A)') ' ======================================='
31204
31205 WRITE(LO,'(/,A,3I10)')
31206 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31207 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31208 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31209 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31210 WRITE(LO,'(/1X,A)') 'x times parton densities'
31211 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31212 WRITE(LO,'(1X,A)')
31213 & ' ============================================================'
31214
31215C logarithmic loop over x values
31216C upper bound
31217 XUPPER=0.9999D0
31218C lower bound
31219 XLOWER=1.D-4
31220C number of steps
31221 NSTEP=50
31222
31223 XFIRST=LOG(XLOWER)
31224 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31225 DO 100 I=1,NSTEP
31226 X=EXP(XFIRST)
31227 XCONTR=X
31228 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31229 IF(X.NE.XCONTR) THEN
31230 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31231 ENDIF
31232 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31233 XFIRST=XFIRST+XDELTA
31234 100 CONTINUE
31235
31236 IF(IDPDG.EQ.22) THEN
31237 WRITE(LO,'(/1X,A)')
31238 & 'comparison PDF to contribution due to box diagram'
31239 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31240 WRITE(LO,'(1X,A)')
31241 & ' ============================================================'
31242 XFIRST=LOG(XLOWER)
31243 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31244 DO 110 I=1,NSTEP
31245 X=EXP(XFIRST)
31246 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31247 DO 120 K=1,4
31248 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31249 120 CONTINUE
31250 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31251 XFIRST=XFIRST+XDELTA
31252 110 CONTINUE
31253 ENDIF
31254
31255C check momentum sum rule
31256
31257 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31258 DO 199 I=-6,6
31259 PDSUM(I) = 0.D0
31260 PDAVE(I) = 0.D0
31261 199 CONTINUE
31262 ITER=5000
31263 DO 200 I=1,ITER
31264 XX=DBLE(I)/DBLE(ITER)
31265 IF(XX.EQ.1.D0) XX = 0.999999D0
31266 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31267 DO 202 K=-6,6
31268 PDSUM(K) = PDSUM(K)+PD(K)/XX
31269 PDAVE(K) = PDAVE(K)+PD(K)
31270 202 CONTINUE
31271 200 CONTINUE
31272 WRITE(LO,'(1X,A)')
31273 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31274 XSUM = 0.D0
31275 DO 204 I=-6,6
31276 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31277 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31278 XSUM = XSUM+PDAVE(I)
31279 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31280 204 CONTINUE
31281 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31282 DO 205 I=1,6
31283 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31284 205 CONTINUE
31285 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31286 WRITE(LO,'(A/)') ' ============================================='
31287
31288C table of F2
31289
31290 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31291 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31292 & '-----------------------------------------------------'
31293 ITER=100
31294 DO 300 I=1,ITER
31295 XX=DBLE(I)/DBLE(ITER)
31296 IF(XX.EQ.1.D0) XX = 0.9999D0
31297 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31298 F2 = 0.D0
31299 DO 302 K=-6,6
31300 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31301 302 CONTINUE
31302 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31303 300 CONTINUE
31304 WRITE(LO,'(A/)') ' ============================================='
31305 END
31306
31307*$ CREATE PHO_REGPAR.FOR
31308*COPY PHO_REGPAR
31309CDECK ID>, PHO_REGPAR
31310 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31311 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31312C**********************************************************************
31313C
31314C registration of particle in /POEVT1/ and /POEVT2/
31315C
31316C input: ISTH status code of particle
31317C -2 initial parton hard scattering
31318C -1 parton
31319C 0 string
31320C 1 visible particle (no color)
31321C 2 decayed particle
31322C IDPDG PDG particle ID code
31323C IDBAM CPC particle ID code
31324C JM1,JM2 first and second mother index
31325C P1..P4 four momentum
31326C IPHIS1 extended history information
31327C IPHIS1<100: JM1 from particle 1
31328C IPHIS1>100: JM1 from particle 2
31329C 1 valence quark
31330C 2 valence diquark
31331C 3 sea quark
31332C 4 sea diquark
31333C (neg. for antipartons)
31334C IPHIS2 extended history information
31335C positive: JM2 from particle 1
31336C negative: JM2 from particle 2
31337C (see IPHIS1)
31338C IC1,IC2 color labels for partons
31339C IMODE 1 register given parton
31340C 0 reset /POEVT1/ and /POEVT2/
31341C 2 return data of entry IPOS
31342C
31343C IPOS position of particle in /POEVT1/
31344C
31345C**********************************************************************
31346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31347 SAVE
31348
31349 PARAMETER (DEPS = 1.D-20)
31350
31351C input/output channels
31352 INTEGER LI,LO
31353 COMMON /POINOU/ LI,LO
31354C event debugging information
31355 INTEGER NMAXD
31356 PARAMETER (NMAXD=100)
31357 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31358 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31359 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31360 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31361C standard particle data interface
31362 INTEGER NMXHEP
31363 PARAMETER (NMXHEP=4000)
31364 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31365 DOUBLE PRECISION PHEP,VHEP
31366 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31367 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31368 & VHEP(4,NMXHEP)
31369C extension to standard particle data interface (PHOJET specific)
31370 INTEGER IMPART,IPHIST,ICOLOR
31371 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31372
31373 IF(IMODE.EQ.1) THEN
31374 IF(IDEB(76).GE.26) THEN
31375 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31376 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31377 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31378 WRITE(LO,'(1X,A,/2X,6I6)')
31379 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31380 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31381 ENDIF
31382 IF(NHEP.EQ.NMXHEP) THEN
31383 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31384 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31385 CALL PHO_ABORT
31386 ENDIF
31387 NHEP = NHEP+1
31388 IDBAMI = IDBAM
31389 IDPDGI = IDPDG
31390 IF(ABS(ISTH).LE.2) THEN
31391 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31392 IDPDGI = ipho_id2pdg(IDBAM)
31393 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31394 IDBAMI = ipho_pdg2id(IDPDG)
31395 ENDIF
31396 ENDIF
31397C standard data
31398 ISTHEP(NHEP) = ISTH
31399 IDHEP(NHEP) = IDPDGI
31400 JMOHEP(1,NHEP) = JM1
31401 JMOHEP(2,NHEP) = JM2
31402C update of mother-daugther relations
31403 IF(ABS(ISTH).LE.1) THEN
31404 IF(JM1.GT.0) THEN
31405 IF(JDAHEP(1,JM1).EQ.0) THEN
31406 JDAHEP(1,JM1) = NHEP
31407 ISTHEP(JM1) = 2
31408 ENDIF
31409 JDAHEP(2,JM1) = NHEP
31410 ENDIF
31411 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31412 IF(JDAHEP(1,JM2).EQ.0) THEN
31413 JDAHEP(1,JM2) = NHEP
31414 ISTHEP(JM2) = 2
31415 ENDIF
31416 JDAHEP(2,JM2) = NHEP
31417 ELSE IF(JM2.LT.0) THEN
31418 DO 100 II=JM1+1,-JM2
31419 IF(JDAHEP(1,II).EQ.0) THEN
31420 JDAHEP(1,II) = NHEP
31421 ISTHEP(II) = 2
31422 ENDIF
31423 JDAHEP(2,II) = NHEP
31424100 CONTINUE
31425 ENDIF
31426 ENDIF
31427 PHEP(1,NHEP) = P1
31428 PHEP(2,NHEP) = P2
31429 PHEP(3,NHEP) = P3
31430 PHEP(4,NHEP) = P4
31431 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31432 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31433 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31434 ELSE
31435 PHEP(5,NHEP) = 0.D0
31436 ENDIF
31437 JDAHEP(1,NHEP) = 0
31438 JDAHEP(2,NHEP) = 0
31439C extended information
31440 IMPART(NHEP) = IDBAMI
31441C extended history information
31442 IPHIST(1,NHEP) = IPHIS1
31443 IPHIST(2,NHEP) = IPHIS2
31444C charge/baryon number or color labels
31445 IF(ISTH.EQ.1) THEN
31446 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31447 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31448 ELSE
31449 ICOLOR(1,NHEP) = IC1
31450 ICOLOR(2,NHEP) = IC2
31451 ENDIF
31452
31453 IPOS = NHEP
31454 IF(IDEB(76).GE.26) THEN
31455 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31456 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31457 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31458 & PHEP(5,NHEP),IPOS
31459 ENDIF
31460
31461 ELSE IF(IMODE.EQ.0) THEN
31462 NHEP = 0
31463 ELSE IF(IMODE.EQ.2) THEN
31464 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31465 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31466 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31467 RETURN
31468 ENDIF
31469 ISTH = ISTHEP(IPOS)
31470 IDPDG = IDHEP(IPOS)
31471 IDBAM = IMPART(IPOS)
31472 JM1 = JMOHEP(1,IPOS)
31473 JM2 = JMOHEP(2,IPOS)
31474 P1 = PHEP(1,IPOS)
31475 P2 = PHEP(2,IPOS)
31476 P3 = PHEP(3,IPOS)
31477 P4 = PHEP(4,IPOS)
31478 IPHIS1= IPHIST(1,IPOS)
31479 IPHIS2= IPHIST(2,IPOS)
31480 IC1 = ICOLOR(1,IPOS)
31481 IC2 = ICOLOR(2,IPOS)
31482 ELSE
31483 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31484 ENDIF
31485 END
31486
31487*$ CREATE IPHO_CNV1.FOR
31488*COPY IPHO_CNV1
31489CDECK ID>, IPHO_CNV1
31490 INTEGER FUNCTION IPHO_CNV1(IPART)
31491C*********************************************************************
31492C
31493C conversion of quark numbering scheme to PARTICLE DATA GROUP
31494C convention
31495C
31496C input: old internal particle code of hard scattering
31497C 0 gluon
31498C 1 d
31499C 2 u
31500C 3 s
31501C 4 c
31502C valence quarks changed to standard numbering
31503C
31504C output: standard particle codes
31505C
31506C*********************************************************************
31507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31508 SAVE
31509C
31510 II = ABS(IPART)
31511C change gluon number
31512 IF(II.EQ.0) THEN
31513 IPHO_CNV1 = 21
31514C change valence quark
31515 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31516 IPHO_CNV1 = SIGN(II-6,IPART)
31517 ELSE
31518 IPHO_CNV1 = IPART
31519 ENDIF
31520 END
31521
31522*$ CREATE PHO_HACODE.FOR
31523*COPY PHO_HACODE
31524CDECK ID>, PHO_HACODE
31525 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31526C*********************************************************************
31527C
31528C determination of hadron index from quarks
31529C
31530C input: ID1,ID2 parton code according to PDG conventions
31531C
31532C output: IDcpc1,2 CPC particle codes
31533C
31534C*********************************************************************
31535 IMPLICIT NONE
31536 SAVE
31537
31538 integer ID1,ID2,IDcpc1,IDcpc2
31539
31540C input/output channels
31541 INTEGER LI,LO
31542 COMMON /POINOU/ LI,LO
31543C event debugging information
31544 INTEGER NMAXD
31545 PARAMETER (NMAXD=100)
31546 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31547 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31548 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31549 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31550C general particle data
31551 double precision xm_list,tau_list,gam_list,
31552 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31553 & xm_bb82_list,xm_bb102_list
31554 integer ich3_list,iba3_list,iq_list,
31555 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31556 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31557 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31558 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31559 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31560 & ich3_list(300),iba3_list(300),iq_list(3,300),
31561 & id_psm_list(6,6),id_vem_list(6,6),
31562 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31563
31564C local variables
31565 integer ii,jj,kk,i1,i2
31566
31567 IDcpc1 = 0
31568 IDcpc2 = 0
31569
31570 if(ID1*ID2.lt.0) then
31571C meson
31572 if(ID1.gt.0) then
31573 ii = ID1
31574 jj = -ID2
31575 else
31576 ii = ID2
31577 jj = -ID1
31578 endif
31579 IDcpc1 = ID_psm_list(ii,jj)
31580 IDcpc2 = ID_vem_list(ii,jj)
31581
31582 else
31583C baryon
31584 i1 = abs(ID1)
31585 i2 = abs(ID2)
31586 if(i1.gt.6) then
31587 ii = i1/1000
31588 jj = (i1-ii*1000)/100
31589 kk = i2
31590 else
31591 ii = i1
31592 jj = i2/1000
31593 kk = (i2-jj*1000)/100
31594 endif
31595 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31596 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31597
31598 endif
31599
31600 END
31601
31602*$ CREATE PHO_ID2STR.FOR
31603*COPY PHO_ID2STR
31604CDECK ID>, PHO_ID2STR
31605 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31606C*********************************************************************
31607C
31608C conversion of quark numbering scheme
31609C
31610C input: standard particle codes:
31611C ID1
31612C ID2
31613C
31614C output: NOBAM CPC string code
31615C quark codes (PDG convention):
31616C IBAM1
31617C IBAM2
31618C IBAM3
31619C IBAM4
31620C
31621C NOBAM = -1 invalid flavour combinations
31622C
31623C*********************************************************************
31624 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31625 SAVE
31626
31627C input/output channels
31628 INTEGER LI,LO
31629 COMMON /POINOU/ LI,LO
31630
31631 IDA1 = ABS(ID1)
31632 IDA2 = ABS(ID2)
31633
31634C quark-antiquark string
31635 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31636 IF((ID1*ID2).GE.0) GOTO 100
31637 IBAM1 = ID1
31638 IBAM2 = ID2
31639 IBAM3 = 0
31640 IBAM4 = 0
31641 NOBAM = 3
31642C quark-diquark string
31643 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31644 IF((ID1*ID2).LE.0) GOTO 100
31645 IBAM1 = ID1
31646 IBAM2 = ID2/1000
31647 IBAM3 = (ID2-IBAM2*1000)/100
31648 IBAM4 = 0
31649 NOBAM = 4
31650C diquark-quark string
31651 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31652 IF((ID1*ID2).LE.0) GOTO 100
31653 IBAM1 = ID1/1000
31654 IBAM2 = (ID1-IBAM1*1000)/100
31655 IBAM3 = ID2
31656 IBAM4 = 0
31657 NOBAM = 6
31658C gluon-gluon string
31659 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31660 IBAM1 = 21
31661 IBAM2 = 21
31662 IBAM3 = 0
31663 IBAM4 = 0
31664 NOBAM = 7
31665C diquark-antidiquark string
31666 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31667 IF((ID1*ID2).GE.0) GOTO 100
31668 IBAM1 = ID1/1000
31669 IBAM2 = (ID1-IBAM1*1000)/100
31670 IBAM3 = ID2/1000
31671 IBAM4 = (ID2-IBAM3*1000)/100
31672 NOBAM = 5
31673 ENDIF
31674 RETURN
31675
31676C invalid combination
31677 100 CONTINUE
31678 WRITE(LO,'(//1X,A,2I10)')
31679 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31680 CALL PHO_ABORT
31681
31682 END
31683
31684*$ CREATE PHO_MKSLTR.FOR
31685*COPY PHO_MKSLTR
31686CDECK ID>, PHO_MKSLTR
31687 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31688C********************************************************************
31689C
31690C calculate successive Lorentz boots for arbitrary Lorentz trans.
31691C
31692C input: P1 initial 4 vector
31693C GAM(3),GAMB(3) Lorentz boost parameters
31694C
31695C output: P2 final 4 vector
31696C
31697C********************************************************************
31698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31699 SAVE
31700
31701 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31702
31703 P2(4) = P1(4)
31704 DO 150 I=1,3
31705 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31706 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31707 150 CONTINUE
31708 END
31709
31710*$ CREATE PHO_GETLTR.FOR
31711*COPY PHO_GETLTR
31712CDECK ID>, PHO_GETLTR
31713 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31714C********************************************************************
31715C
31716C calculate Lorentz boots for arbitrary Lorentz transformation
31717C
31718C input: P1 initial 4 vector
31719C P2 final 4 vector
31720C
31721C output: GAM(3),GAMB(3)
31722C DELE energy deviation
31723C IREJ 0 success
31724C 1 failure
31725C
31726C********************************************************************
31727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31728 SAVE
31729
31730 PARAMETER ( DREL = 0.001D0 )
31731
31732C input/output channels
31733 INTEGER LI,LO
31734 COMMON /POINOU/ LI,LO
31735
31736 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31737
31738 IREJ = 1
31739 DO 50 K=1,4
31740 PA(K) = P1(K)
31741 PP(K) = P1(K)
31742 50 CONTINUE
31743 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31744 DO 100 I=1,3
31745 PP(I) = P2(I)
31746 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31747 IF(PP(4).LE.0.D0) RETURN
31748 PP(4) = SQRT(PP(4))
31749 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31750 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31751 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31752 GAMB(I) = GAMB(I)*GAM(I)
31753 DO 150 K=1,4
31754 PA(K) = PP(K)
31755 150 CONTINUE
31756 100 CONTINUE
31757 DELE = P2(4)-PP(4)
31758 IREJ = 0
31759C consistency check
31760* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31761* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31762* WRITE(LO,'(/1X,A,2E12.5)')
31763* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31764* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31765* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31766* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31767* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31768* ENDIF
31769 END
31770
31771*$ CREATE PHO_ALTRA.FOR
31772*COPY PHO_ALTRA
31773CDECK ID>, PHO_ALTRA
31774 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31775C*********************************************************************
31776C
31777C arbitrary Lorentz transformation
31778C
31779C*********************************************************************
31780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31781 SAVE
31782
31783 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31784 PE=EP/(GA+1.D0)+EC
31785 PX=PCX+BGX*PE
31786 PY=PCY+BGY*PE
31787 PZ=PCZ+BGZ*PE
31788 P=SQRT(PX*PX+PY*PY+PZ*PZ)
31789 E=GA*EC+EP
31790
31791 END
31792
31793*$ CREATE PHO_LTRANS.FOR
31794*COPY PHO_LTRANS
31795CDECK ID>, PHO_LTRANS
31796 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31797 & PL,CXL,CYL,CZL,EL)
31798C**********************************************************************
31799C
31800C Lorentz transformation into lab - system
31801C
31802C**********************************************************************
31803 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31804 SAVE
31805
31806 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31807
31808C input/output channels
31809 INTEGER LI,LO
31810 COMMON /POINOU/ LI,LO
31811
31812 SID=SQRT(1.D0-COD*COD)
31813 PLX=P*SID*COF
31814 PLY=P*SID*SIF
31815 PCMZ=P*COD
31816 PLZ=GAM*PCMZ+BGAM*ECM
31817 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31818 EL=GAM*ECM+BGAM*PCMZ
31819
31820C rotation into the original direction
31821 COZ=PLZ/PL
31822 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31823
31824* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31825
31826 AX=ABS(CX)
31827 AY=ABS(CY)
31828 IF(AX.LT.AY) THEN
31829 AMAX=AY
31830 AMIN=AX
31831 ELSE
31832 AMAX=AX
31833 AMIN=AY
31834 ENDIF
31835 IF (ABS(CX)-TINY) 1,1,2
31836 1 IF (ABS(CY)-TINY) 3,3,2
31837
31838 3 CONTINUE
ecf67adb 31839* WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
9aaba0d6 31840 CXL=SIZ*COF
31841 CYL=SIZ*SIF
31842 CZL=COZ*CZ
ecf67adb 31843* WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
9aaba0d6 31844* WRITE(LO,*) CXL,CYL,CZL
31845 RETURN
31846
31847 2 CONTINUE
31848 IF(AMAX.GT.TINY2) THEN
31849 AR=AMIN/AMAX
31850 AR=AR*AR
31851 A=AMAX*SQRT(1.D0+AR)
31852 ELSE
ecf67adb 31853* WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
9aaba0d6 31854 GOTO 3
31855 ENDIF
31856 XI=SIZ*COF
31857 YI=SIZ*SIF
31858 ZI=COZ
31859 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31860 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31861 CZL=A*YI+CZ*ZI
31862
31863 END
31864
31865*$ CREATE PHO_TRANS.FOR
31866*COPY PHO_TRANS
31867CDECK ID>, PHO_TRANS
31868 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31869C**********************************************************************
31870C
31871C rotation of coordinate frame (1) de rotation around y axis
31872C (2) fe rotation around z axis
31873C (inverse rotation to PHO_TRANI)
31874C
31875C**********************************************************************
31876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31877 SAVE
31878
31879 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31880 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31881 Z=-SDE *XO +CDE *ZO
31882
31883 END
31884
31885*$ CREATE PHO_TRANI.FOR
31886*COPY PHO_TRANI
31887CDECK ID>, PHO_TRANI
31888 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31889C**********************************************************************
31890C
31891C rotation of coordinate frame (1) -fe rotation around z axis
31892C (2) -de rotation around y axis
31893C (inverse rotation to PHO_TRANS)
31894C
31895C**********************************************************************
31896 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31897 SAVE
31898
31899 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31900 Y=-SFE *XO+CFE* YO
31901 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31902
31903 END
31904
31905*$ CREATE pho_cpcini.FOR
31906*COPY pho_cpcini
31907CDECK ID>, pho_cpcini
31908 SUBROUTINE pho_cpcini(Nrows,Number,List)
31909C***********************************************************************
31910C
31911C initialization of particle hash table
31912C
31913C input: Number vector with Nrows entries according to PDG
31914C convention
31915C
31916C output: List vector with hash table
31917C
31918C (this code is based on the function initpns written by
31919C Gerry Lynch, LBL, January 1990)
31920C
31921C***********************************************************************
31922 IMPLICIT NONE
31923 SAVE
31924
31925C input/output channels
31926 INTEGER LI,LO
31927 COMMON /POINOU/ LI,LO
31928
31929 integer Number(*),List(*),Nrows
31930
31931 Integer Nin,Nout,Ip,I
31932
31933 do I = 1,577
31934 List(I) = 0
31935 enddo
31936
31937C Loop over all of the elements in the Number vector
31938
31939 Do 500 Ip = 1,Nrows
31940 Nin = Number(Ip)
31941
31942C Calculate a list number for this particle id number
31943 If(Nin.Gt.99999.or.Nin.Le.0) Then
31944 Nout = -1
31945 Else If(Nin.Le.577) Then
31946 Nout = Nin
31947 Else
31948 Nout = Mod(Nin,577)
31949 End If
31950
31951 200 continue
31952
31953 If(Nout.Lt.0) Then
31954C Count the bad entries
31955 WRITE(LO,'(1x,a,i10)')
31956 & 'pho_cpcini: invalid particle ID',Nin
31957 Go to 500
31958 End If
31959 If(List(Nout).eq.0) Then
31960 List(Nout) = Ip
31961 Else
31962 If(Nin.eq.Number(List(Nout))) Then
31963 WRITE(LO,'(1x,a,i10)')
31964 & 'pho_cpcini: double particle ID',Nin
31965 End If
31966 Nout = Nout + 5
31967 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31968
31969 Go to 200
31970 End If
31971 500 Continue
31972
31973 END
31974
31975*$ CREATE ipho_pdg2id.FOR
31976*COPY ipho_pdg2id
31977CDECK ID>, ipho_pdg2id
31978 INTEGER FUNCTION ipho_pdg2id(IDpdg)
31979C**********************************************************************
31980C
31981C calculation internal particle code using the particle index i
31982C according to the PDG proposal.
31983C
31984C input: IDpdg PDG particle number
31985C output: ipho_pdg2id internal particle code
31986C (0 for invalid IDpdg)
31987C
31988C the hash algorithm is based on a program by Gerry Lynch
31989C
31990C**********************************************************************
31991 IMPLICIT NONE
31992 SAVE
31993
31994 integer IDpdg
31995
31996C input/output channels
31997 INTEGER LI,LO
31998 COMMON /POINOU/ LI,LO
31999C event debugging information
32000 INTEGER NMAXD
32001 PARAMETER (NMAXD=100)
32002 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32003 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32004 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32005 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32006C particle ID translation table
32007 integer ID_pdg_list,ID_list,ID_pdg_max
32008 character*12 name_list
32009 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32010 & ID_pdg_max
32011
32012 integer Nin,Nout
32013
32014 Nin = abs(IDpdg)
32015
32016 if((Nin.gt.99999).or.(Nin.eq.0)) then
32017C invalid particle number
32018 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32019 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32020 ipho_pdg2id = 0
32021 return
32022 else If(Nin.le.577) then
32023C simple case
32024 Nout = Nin
32025 else
32026C use hash algorithm
32027 Nout = mod(Nin,577)
32028 endif
32029
32030 100 continue
32031
32032C particle not in table
32033 if(ID_list(Nout).Eq.0) then
32034 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32035 & 'ipho_pdg2id: particle not in table ',IDpdg
32036 ipho_pdg2id = 0
32037 return
32038 endif
32039
32040 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32041C particle ID found
32042 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32043 return
32044 else
32045C increment and try again
32046 Nout = Nout + 5
32047 If(Nout.gt.577) Nout = Mod(Nout,577)
32048 goto 100
32049 endif
32050
32051 END
32052
32053*$ CREATE IPHO_ID2PDG.FOR
32054*COPY IPHO_ID2PDG
32055CDECK ID>, IPHO_ID2PDG
32056 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32057C**********************************************************************
32058C
32059C conversion of internal particle code to PDG standard
32060C
32061C input: IDcpc internal particle number
32062C output: ipho_id2pdg PDG particle number
32063C (0 for invalid IDcpc)
32064C
32065C**********************************************************************
32066 IMPLICIT NONE
32067 SAVE
32068
32069 integer IDcpc
32070
32071C input/output channels
32072 INTEGER LI,LO
32073 COMMON /POINOU/ LI,LO
32074C event debugging information
32075 INTEGER NMAXD
32076 PARAMETER (NMAXD=100)
32077 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32078 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32079 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32080 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32081C particle ID translation table
32082 integer ID_pdg_list,ID_list,ID_pdg_max
32083 character*12 name_list
32084 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32085 & ID_pdg_max
32086
32087 integer IDabs
32088
32089 IDabs = abs(IDcpc)
32090 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32091 ipho_id2pdg = 0
32092 return
32093 endif
32094
32095 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32096
32097 END
32098
32099*$ CREATE IPHO_LU2PDG.FOR
32100*COPY IPHO_LU2PDG
32101CDECK ID>, IPHO_LU2PDG
32102 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32103C**********************************************************************
32104C
32105C conversion of JETSET KF code to PDG code
32106C
32107C**********************************************************************
32108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32109 SAVE
32110 PARAMETER (NTAB=10)
32111 DIMENSION LU2PD(2,NTAB)
32112 DATA LU2PD / 4232, 4322,
32113 & 4322, 4232,
32114 & 3212, 3122,
32115 & 3122, 3212,
32116 & 30553, 20553,
32117 & 30443, 20443,
32118 & 20443, 10443,
32119 & 10443, 0,
32120 & 511, 0,
32121 & 10551, 551 /
32122C
32123 DO 100 I=1,NTAB
32124 IF(LU2PD(1,I).EQ.LUKF) THEN
32125 IPHO_LU2PDG=LU2PD(2,I)
32126 RETURN
32127 ENDIF
32128 100 CONTINUE
32129 IPHO_LU2PDG=LUKF
32130
32131 END
32132
32133*$ CREATE IPHO_PDG2LU.FOR
32134*COPY IPHO_PDG2LU
32135CDECK ID>, IPHO_PDG2LU
32136 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32137C**********************************************************************
32138C
32139C conversion of PDG code to JETSET code
32140C
32141C**********************************************************************
32142 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32143 SAVE
32144 PARAMETER (NTAB=8)
32145 DIMENSION LU2PD(2,NTAB)
32146 DATA LU2PD / 4232, 4322,
32147 & 4322, 4232,
32148 & 3212, 3122,
32149 & 3122, 3212,
32150 & 30553, 20553,
32151 & 30443, 20443,
32152 & 20443, 10443,
32153 & 10551, 551 /
32154C
32155 DO 100 I=1,NTAB
32156 IF(LU2PD(2,I).EQ.IPDG) THEN
32157 IPHO_PDG2LU=LU2PD(1,I)
32158 RETURN
32159 ENDIF
32160 100 CONTINUE
32161 IPHO_PDG2LU=IPDG
32162
32163 END
32164
32165*$ CREATE pho_pname.FOR
32166*COPY pho_pname
32167CDECK ID>, pho_pname
32168 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32169C***********************************************************************
32170C
32171C returns particle name for given ID number
32172C
32173C input: ID particle ID number
32174C mode 0: ID treated as compressed particle code
32175C 1: ID treated as PDG number
32176C
32177C***********************************************************************
32178 IMPLICIT NONE
32179 SAVE
32180
32181 integer ID,mode
32182
32183C input/output channels
32184 INTEGER LI,LO
32185 COMMON /POINOU/ LI,LO
32186C standard particle data interface
32187 INTEGER NMXHEP
32188 PARAMETER (NMXHEP=4000)
32189 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32190 DOUBLE PRECISION PHEP,VHEP
32191 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32192 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32193 & VHEP(4,NMXHEP)
32194C extension to standard particle data interface (PHOJET specific)
32195 INTEGER IMPART,IPHIST,ICOLOR
32196 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32197C particle ID translation table
32198 integer ID_pdg_list,ID_list,ID_pdg_max
32199 character*12 name_list
32200 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32201 & ID_pdg_max
32202C general particle data
32203 double precision xm_list,tau_list,gam_list,
32204 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32205 & xm_bb82_list,xm_bb102_list
32206 integer ich3_list,iba3_list,iq_list,
32207 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32208 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32209 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32210 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32211 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32212 & ich3_list(300),iba3_list(300),iq_list(3,300),
32213 & id_psm_list(6,6),id_vem_list(6,6),
32214 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32215
32216C external functions
32217 integer ipho_id2pdg,ipho_pdg2id
32218
32219C local variables
32220 integer IDpdg,i,ii,k,l,ichar,i_anti
32221 character*15 name
32222
32223 pho_pname = '(?????????????)'
32224
32225 if(mode.eq.0) then
32226 i = ID
32227 IDpdg = ipho_id2pdg(ID)
32228 if(IDpdg.eq.0) return
32229 else if(mode.eq.1) then
32230 i = ipho_pdg2id(ID)
32231 if(i.eq.0) return
32232 IDpdg = ID
32233 else if(mode.eq.2) then
32234 if(ISTHEP(ID).gt.11) then
32235 if(ISTHEP(ID).eq.20) then
32236 pho_pname = 'hard ini. part.'
32237 else if(ISTHEP(ID).eq.21) then
32238 pho_pname = 'hard fin. part.'
32239 else if(ISTHEP(ID).eq.25) then
32240 pho_pname = 'hard scattering'
32241 else if(ISTHEP(ID).eq.30) then
32242 pho_pname = 'diff. diss. '
32243 else if(ISTHEP(ID).eq.35) then
32244 pho_pname = 'elastic scatt. '
32245 else if(ISTHEP(ID).eq.40) then
32246 pho_pname = 'central scatt. '
32247 endif
32248 return
32249 endif
32250 IDpdg = IDHEP(ID)
32251 i = IMPART(ID)
32252 else
32253 WRITE(LO,'(1x,a,2i4)')
32254 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32255 return
32256 endif
32257
32258 ii = abs(i)
32259 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32260
32261 name = name_list(ii)
32262 ichar = ich3_list(ii)*sign(1,i)
32263 if(mod(ichar,3).ne.0) then
32264 ichar = 0
32265 else
32266 ichar = ichar/3
32267 endif
32268
32269C find position of first blank character
32270 k = 1
32271 100 continue
32272 k = k+1
32273 if(name(k:k).ne.' ') goto 100
32274
32275C append anti-particle sign
32276 if(i.lt.0) then
32277 i_anti = 0
32278 do l=1,3
32279 i_anti = i_anti+iq_list(l,ii)
32280 enddo
32281 if(iba3_list(ii).ne.0) then
32282 name(k:k) = '~'
32283 k = K+1
32284 else if(((i_anti.ne.0).and.(ichar.eq.0))
32285 & .or.(IDpdg.eq.-12)
32286 & .or.(IDpdg.eq.-14)
32287 & .or.(IDpdg.eq.-16)) then
32288 name(k:k) = '~'
32289 k = K+1
32290 endif
32291 endif
32292
32293C append charge sign
32294 if(ichar.eq.-2) then
32295 name(k:k+1) = '--'
32296 else if(ichar.eq.-1) then
32297 name(k:k) = '-'
32298 else if(ichar.eq.1) then
32299 name(k:k) = '+'
32300 else if(ichar.eq.2) then
32301 name(k:k+1) = '++'
32302 endif
32303
32304 pho_pname = name
32305
32306 END
32307
32308*$ CREATE ipho_anti.FOR
32309*COPY ipho_anti
32310CDECK ID>, ipho_anti
32311 INTEGER FUNCTION ipho_anti(ID)
32312C**********************************************************************
32313C
32314C determine antiparticle for given ID
32315C
32316C input: ID gives CPC particle number
32317C
32318C output: ipho_anti antiparticle code
32319C
32320C**********************************************************************
32321 IMPLICIT NONE
32322 SAVE
32323
32324 integer ID
32325
32326C input/output channels
32327 INTEGER LI,LO
32328 COMMON /POINOU/ LI,LO
32329C event debugging information
32330 INTEGER NMAXD
32331 PARAMETER (NMAXD=100)
32332 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32333 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32334 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32335 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32336C particle ID translation table
32337 integer ID_pdg_list,ID_list,ID_pdg_max
32338 character*12 name_list
32339 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32340 & ID_pdg_max
32341C general particle data
32342 double precision xm_list,tau_list,gam_list,
32343 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32344 & xm_bb82_list,xm_bb102_list
32345 integer ich3_list,iba3_list,iq_list,
32346 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32347 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32348 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32349 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32350 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32351 & ich3_list(300),iba3_list(300),iq_list(3,300),
32352 & id_psm_list(6,6),id_vem_list(6,6),
32353 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32354C standard particle data interface
32355 INTEGER NMXHEP
32356 PARAMETER (NMXHEP=4000)
32357 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32358 DOUBLE PRECISION PHEP,VHEP
32359 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32360 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32361 & VHEP(4,NMXHEP)
32362C extension to standard particle data interface (PHOJET specific)
32363 INTEGER IMPART,IPHIST,ICOLOR
32364 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32365
32366C external functions
32367 integer ipho_id2pdg,ipho_pdg2id
32368
32369C local variables
32370 integer IDabs,IDpdg,i_anti,l
32371
32372 ipho_anti = -ID
32373 IDabs = abs(ID)
32374
32375C baryons
32376 if(iba3_list(IDabs).ne.0) return
32377
32378C charged particles
32379 if(ich3_list(IDabs).ne.0) return
32380
32381C K0_s and K0_l
32382 IDpdg = ipho_id2pdg(ID)
32383 if(IDpdg.eq.310) then
32384 ID = ipho_pdg2id(130)
32385 return
32386 else if(IDpdg.eq.130) then
32387 ID = ipho_pdg2id(310)
32388 return
32389 endif
32390
32391C neutral mesons with open strangeness, charm, or beauty
32392 i_anti = 0
32393 do l=1,3
32394 i_anti = i_anti+iq_list(l,IDabs)
32395 enddo
32396 if(i_anti.ne.0) return
32397
32398C neutrinos
32399 IDpdg = abs(IDpdg)
32400 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32401
32402 ipho_anti = ID
32403
32404 END
32405
32406*$ CREATE ipho_chr3.FOR
32407*COPY ipho_chr3
32408CDECK ID>, ipho_chr3
32409 INTEGER FUNCTION ipho_chr3(ID,mode)
32410C**********************************************************************
32411C
32412C output of three times the electric charge
32413C
32414C input: mode
32415C 0 ID gives CPC particle number
32416C 1 ID gives PDG particle number
32417C 2 ID gives position of particle in /POEVT1/
32418C
32419C**********************************************************************
32420 IMPLICIT NONE
32421 SAVE
32422
32423 integer ID,mode
32424
32425C input/output channels
32426 INTEGER LI,LO
32427 COMMON /POINOU/ LI,LO
32428C event debugging information
32429 INTEGER NMAXD
32430 PARAMETER (NMAXD=100)
32431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32435C standard particle data interface
32436 INTEGER NMXHEP
32437 PARAMETER (NMXHEP=4000)
32438 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32439 DOUBLE PRECISION PHEP,VHEP
32440 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32441 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32442 & VHEP(4,NMXHEP)
32443C extension to standard particle data interface (PHOJET specific)
32444 INTEGER IMPART,IPHIST,ICOLOR
32445 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32446C particle ID translation table
32447 integer ID_pdg_list,ID_list,ID_pdg_max
32448 character*12 name_list
32449 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32450 & ID_pdg_max
32451C general particle data
32452 double precision xm_list,tau_list,gam_list,
32453 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32454 & xm_bb82_list,xm_bb102_list
32455 integer ich3_list,iba3_list,iq_list,
32456 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32457 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32458 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32459 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32460 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32461 & ich3_list(300),iba3_list(300),iq_list(3,300),
32462 & id_psm_list(6,6),id_vem_list(6,6),
32463 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32464
32465C external functions
32466 integer ipho_pdg2id
32467
32468C local variables
32469 integer i,IDpdg
32470
32471 ipho_chr3 = 0
32472
32473 if(mode.eq.0) then
32474 i = ID
32475 else if(mode.eq.1) then
32476 i = ipho_pdg2id(ID)
32477 if(i.eq.0) return
32478 IDpdg = ID
32479 else if(mode.eq.2) then
32480 if(ISTHEP(ID).gt.11) return
32481 i = IMPART(ID)
32482 IDpdg = IDHEP(ID)
32483 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32484 ipho_chr3 = ICOLOR(1,ID)
32485 return
32486 endif
32487 else
32488 WRITE(LO,'(1x,a,2i4)')
32489 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32490 return
32491 endif
32492
32493 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32494 WRITE(LO,'(1x,a,3i8)')
32495 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32496 ipho_chr3 = 1.D0/dble(i)
32497 call pho_prevnt(0)
32498 return
32499 endif
32500
32501 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32502
32503 END
32504
32505*$ CREATE ipho_bar3.FOR
32506*COPY ipho_bar3
32507CDECK ID>, ipho_bar3
32508 INTEGER FUNCTION ipho_bar3(ID,mode)
32509C**********************************************************************
32510C
32511C output of three times the baryon charge
32512C
32513C index: MODE
32514C 0 ID gives CPC particle number
32515C 1 ID gives PDG particle number
32516C 2 ID gives position of particle in /POEVT1/
32517C
32518C**********************************************************************
32519 IMPLICIT NONE
32520 SAVE
32521
32522 integer ID,mode
32523
32524C input/output channels
32525 INTEGER LI,LO
32526 COMMON /POINOU/ LI,LO
32527C event debugging information
32528 INTEGER NMAXD
32529 PARAMETER (NMAXD=100)
32530 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32531 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32532 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32533 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32534C standard particle data interface
32535 INTEGER NMXHEP
32536 PARAMETER (NMXHEP=4000)
32537 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32538 DOUBLE PRECISION PHEP,VHEP
32539 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32540 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32541 & VHEP(4,NMXHEP)
32542C extension to standard particle data interface (PHOJET specific)
32543 INTEGER IMPART,IPHIST,ICOLOR
32544 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32545C particle ID translation table
32546 integer ID_pdg_list,ID_list,ID_pdg_max
32547 character*12 name_list
32548 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32549 & ID_pdg_max
32550C general particle data
32551 double precision xm_list,tau_list,gam_list,
32552 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32553 & xm_bb82_list,xm_bb102_list
32554 integer ich3_list,iba3_list,iq_list,
32555 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32556 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32557 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32558 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32559 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32560 & ich3_list(300),iba3_list(300),iq_list(3,300),
32561 & id_psm_list(6,6),id_vem_list(6,6),
32562 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32563
32564C external functions
32565 integer ipho_pdg2id
32566
32567C local variables
32568 integer i,IDpdg
32569
32570 ipho_bar3 = 0
32571
32572 if(mode.eq.0) then
32573 i = ID
32574 else if(mode.eq.1) then
32575 i = ipho_pdg2id(ID)
32576 if(i.eq.0) return
32577 IDpdg = ID
32578 else if(mode.eq.2) then
32579 if(ISTHEP(ID).gt.11) return
32580 i = IMPART(ID)
32581 IDpdg = IDHEP(ID)
32582 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32583 ipho_bar3 = ICOLOR(2,ID)
32584 return
32585 endif
32586 else
32587 WRITE(LO,'(1x,a,2i4)')
32588 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32589 return
32590 endif
32591
32592 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32593 WRITE(LO,'(1x,a,3i8)')
32594 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32595 ipho_bar3 = 1.D0/dble(i)
32596 return
32597 endif
32598
32599 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32600
32601 END
32602
32603*$ CREATE pho_pmass.FOR
32604*COPY pho_pmass
32605CDECK ID>, pho_pmass
32606 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32607C***********************************************************************
32608C
32609C particle mass
32610C
32611C input: mode -1 initialization
32612C 0 ID gives CPC particle number
32613C 1 ID gives PDG particle number,
32614C (for quarks current masses are returned)
32615C 2 ID gives position of particle in /POEVT1/
32616C 3 ID gives PDG parton number,
32617C (for quarks constituent masses are returned)
32618C
32619C output: average particle mass (in GeV)
32620C
32621C***********************************************************************
32622 IMPLICIT NONE
32623 SAVE
32624
32625 integer ID,mode,MSTJ24
32626
32627C input/output channels
32628 INTEGER LI,LO
32629 COMMON /POINOU/ LI,LO
32630C event debugging information
32631 INTEGER NMAXD
32632 PARAMETER (NMAXD=100)
32633 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32634 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32635 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32636 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32637C model switches and parameters
32638 CHARACTER*8 MDLNA
32639 INTEGER ISWMDL,IPAMDL
32640 DOUBLE PRECISION PARMDL
32641 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32642C standard particle data interface
32643 INTEGER NMXHEP
32644 PARAMETER (NMXHEP=4000)
32645 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32646 DOUBLE PRECISION PHEP,VHEP
32647 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32648 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32649 & VHEP(4,NMXHEP)
32650C extension to standard particle data interface (PHOJET specific)
32651 INTEGER IMPART,IPHIST,ICOLOR
32652 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32653C particle ID translation table
32654 integer ID_pdg_list,ID_list,ID_pdg_max
32655 character*12 name_list
32656 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32657 & ID_pdg_max
32658C general particle data
32659 double precision xm_list,tau_list,gam_list,
32660 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32661 & xm_bb82_list,xm_bb102_list
32662 integer ich3_list,iba3_list,iq_list,
32663 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32664 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32665 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32666 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32667 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32668 & ich3_list(300),iba3_list(300),iq_list(3,300),
32669 & id_psm_list(6,6),id_vem_list(6,6),
32670 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32671 INTEGER MSTU,MSTJ
32672 DOUBLE PRECISION PARU,PARJ
32673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32674
32675C external functions
32676 integer ipho_pdg2id,ipho_id2pdg
32677 DOUBLE PRECISION PYMASS
32678
32679C local variables
32680 integer i,IDpdg
32681
32682 pho_pmass = 0.D0
32683
32684 if(mode.eq.0) then
32685 i = ID
32686 else if(mode.eq.1) then
32687 i = ipho_pdg2id(ID)
32688 if(i.eq.0) return
32689 else if(mode.eq.2) then
32690 if(ISTHEP(ID).gt.11) return
32691 i = IMPART(ID)
32692 IDpdg = IDHEP(ID)
32693 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32694 pho_pmass = PHEP(5,ID)
32695 return
32696 endif
32697 else if(mode.eq.3) then
32698 i = abs(ID)
32699 if((i.gt.0).and.(i.le.6)) then
32700 pho_pmass = PARMDL(150+i)
32701 return
32702 else
32703 i = ipho_pdg2id(ID)
32704 if(i.eq.0) return
32705 endif
32706 else if(mode.eq.-1) then
32707C initialization: take masses for quarks and di-quarks from JETSET
32708 MSTJ24 = MSTJ(24)
32709 MSTJ(24) = 0
32710 do i=1,22
32711 IDpdg = ipho_id2pdg(i)
32712 xm_list(i) = PYMASS(IDpdg)
32713 enddo
32714 MSTJ(24) = MSTJ24
32715 return
32716 else
32717 WRITE(LO,'(1x,a,2i4)')
32718 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32719 return
32720 endif
32721
32722 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32723 WRITE(LO,'(1x,a,2i8)')
32724 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32725 pho_pmass = 1.D0/dble(i)
32726 return
32727 endif
32728
32729 pho_pmass = xm_list(iabs(i))
32730
32731 END
32732
32733*$ CREATE PHO_MEMASS.FOR
32734*COPY PHO_MEMASS
32735CDECK ID>, PHO_MEMASS
32736 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32737C**********************************************************************
32738C
32739C determine meson masses corresponding to the input flavours
32740C
32741C input: I,J,K quark flavours (PDG convention)
32742C
32743C output: AMPS pseudo scalar meson mass
32744C AMPS2 next possible two particle configuration
32745C (two pseudo scalar mesons)
32746C AMVE vector meson mass
32747C AMVE2 next possible two particle configuration
32748C (two vector mesons)
32749C IPS,IVE meson numbers in CPC
32750C
32751C**********************************************************************
32752 IMPLICIT NONE
32753 SAVE
32754
32755 integer I,J,IPS,IVE
32756 double precision AMPS,AMPS2,AMVE,AMVE2
32757
32758C input/output channels
32759 INTEGER LI,LO
32760 COMMON /POINOU/ LI,LO
32761C event debugging information
32762 INTEGER NMAXD
32763 PARAMETER (NMAXD=100)
32764 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32765 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32766 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32767 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32768C particle ID translation table
32769 integer ID_pdg_list,ID_list,ID_pdg_max
32770 character*12 name_list
32771 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32772 & ID_pdg_max
32773C general particle data
32774 double precision xm_list,tau_list,gam_list,
32775 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32776 & xm_bb82_list,xm_bb102_list
32777 integer ich3_list,iba3_list,iq_list,
32778 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32779 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32780 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32781 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32782 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32783 & ich3_list(300),iba3_list(300),iq_list(3,300),
32784 & id_psm_list(6,6),id_vem_list(6,6),
32785 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32786
32787C local variables
32788 integer ii,jj
32789
32790 IF(I.GT.0) THEN
32791 ii = I
32792 jj = -J
32793 ELSE
32794 ii = J
32795 jj = -I
32796 ENDIF
32797
32798C particle ID's
32799 IPS = id_psm_list(ii,jj)
32800 IVE = id_vem_list(ii,jj)
32801C masses
32802 if(IPS.ne.0) then
32803 AMPS = xm_list(iabs(IPS))
32804 else
32805 AMPS = 0.D0
32806 endif
32807 if(IVE.ne.0) then
32808 AMVE = xm_list(iabs(IVE))
32809 else
32810 AMVE = 0.D0
32811 endif
32812
32813C next possible two-particle configurations (add phase space)
32814 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32815 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32816
32817 END
32818
32819*$ CREATE PHO_BAMASS.FOR
32820*COPY PHO_BAMASS
32821CDECK ID>, PHO_BAMASS
32822 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32823C**********************************************************************
32824C
32825C determine baryon masses corresponding to the input flavours
32826C
32827C input: I,J,K quark flavours (PDG convention)
32828C
32829C output: AM8 octett baryon mass
32830C AM82 next possible two particle configuration
32831C (octett baryon and meson)
32832C AM10 decuplett baryon mass
32833C AM102 next possible two particle configuration
32834C (decuplett baryon and meson,
32835C baryon built up from first two quarks)
32836C I8,I10 internal baryon numbers
32837C
32838C**********************************************************************
32839 IMPLICIT NONE
32840 SAVE
32841
32842 integer I,J,K,I8,I10
32843 double precision AM8,AM82,AM10,AM102
32844
32845C input/output channels
32846 INTEGER LI,LO
32847 COMMON /POINOU/ LI,LO
32848C event debugging information
32849 INTEGER NMAXD
32850 PARAMETER (NMAXD=100)
32851 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32852 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32853 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32854 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32855C particle ID translation table
32856 integer ID_pdg_list,ID_list,ID_pdg_max
32857 character*12 name_list
32858 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32859 & ID_pdg_max
32860C general particle data
32861 double precision xm_list,tau_list,gam_list,
32862 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32863 & xm_bb82_list,xm_bb102_list
32864 integer ich3_list,iba3_list,iq_list,
32865 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32866 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32867 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32868 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32869 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32870 & ich3_list(300),iba3_list(300),iq_list(3,300),
32871 & id_psm_list(6,6),id_vem_list(6,6),
32872 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32873
32874C local variables
32875 integer ii,jj,kk
32876
32877C find particle ID's
32878 ii = iabs(I)
32879 jj = iabs(J)
32880 kk = iabs(K)
32881 I8 = id_b8_list(ii,jj,kk)
32882 I10 = id_b10_list(ii,jj,kk)
32883
32884C masses (if combination possible)
32885 if(I8.ne.0) then
32886 AM8 = xm_list(I8)
32887 I8 = sign(I8,i)
32888 else
32889 AM8 = 0.D0
32890 endif
32891 if(I10.ne.0) then
32892 AM10 = xm_list(I10)
32893 I10 = sign(I10,i)
32894 else
32895 AM10 = 0.D0
32896 endif
32897
32898C next possible two-particle configurations (add phase space)
32899 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32900 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32901
32902 END
32903
32904*$ CREATE PHO_DQMASS.FOR
32905*COPY PHO_DQMASS
32906CDECK ID>, PHO_DQMASS
32907 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32908C**********************************************************************
32909C
32910C determine minimal masses corresponding to the input flavours
32911C (diquark a-diquark string system)
32912C
32913C input: I,J,K,L quark flavours (PDG convention)
32914C
32915C output: AM82 mass of two octett baryons
32916C AM102 mass of two decuplett baryons
32917C
32918C**********************************************************************
32919 IMPLICIT NONE
32920 SAVE
32921
32922 integer I,J,K,L
32923 double precision AM82,AM102
32924
32925C input/output channels
32926 INTEGER LI,LO
32927 COMMON /POINOU/ LI,LO
32928C event debugging information
32929 INTEGER NMAXD
32930 PARAMETER (NMAXD=100)
32931 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32932 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32933 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32934 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32935C general particle data
32936 double precision xm_list,tau_list,gam_list,
32937 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32938 & xm_bb82_list,xm_bb102_list
32939 integer ich3_list,iba3_list,iq_list,
32940 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32941 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32942 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32943 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32944 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32945 & ich3_list(300),iba3_list(300),iq_list(3,300),
32946 & id_psm_list(6,6),id_vem_list(6,6),
32947 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32948
32949C local variables
32950 integer ii,jj,kk,ll
32951
32952 ii = iabs(i)
32953 kk = iabs(k)
32954 jj = iabs(j)
32955 ll = iabs(l)
32956
32957 AM82 = xm_bb82_list(ii,jj,kk,ll)
32958 AM102 = xm_bb102_list(ii,jj,kk,ll)
32959
32960 END
32961
32962*$ CREATE PHO_CHECK.FOR
32963*COPY PHO_CHECK
32964CDECK ID>, PHO_CHECK
32965 SUBROUTINE PHO_CHECK(MD,IDEV)
32966C**********************************************************************
32967C
32968C check quantum numbers of entries in /POEVT1/ and /POEVT2/
32969C (energy, momentum, charge, baryon number conservation)
32970C
32971C input: MD -1 check overall momentum conservation
32972C and perform detailed check only in case of
32973C deviations
32974C 1 test all branchings, mother-daughter
32975C relations
32976C
32977C output: IDEV 0 no deviations
32978C 1 deviations found
32979C
32980C**********************************************************************
32981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32982 SAVE
32983
32984C input/output channels
32985 INTEGER LI,LO
32986 COMMON /POINOU/ LI,LO
32987C event debugging information
32988 INTEGER NMAXD
32989 PARAMETER (NMAXD=100)
32990 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32991 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32992 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32993 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32994C model switches and parameters
32995 CHARACTER*8 MDLNA
32996 INTEGER ISWMDL,IPAMDL
32997 DOUBLE PRECISION PARMDL
32998 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32999C global event kinematics and particle IDs
33000 INTEGER IFPAP,IFPAB
33001 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33002 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33003C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33004 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33005 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33006 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33007 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33008C standard particle data interface
33009 INTEGER NMXHEP
33010 PARAMETER (NMXHEP=4000)
33011 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33012 DOUBLE PRECISION PHEP,VHEP
33013 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33014 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33015 & VHEP(4,NMXHEP)
33016C extension to standard particle data interface (PHOJET specific)
33017 INTEGER IMPART,IPHIST,ICOLOR
33018 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33019C color string configurations including collapsed strings and hadrons
33020 INTEGER MSTR
33021 PARAMETER (MSTR=500)
33022 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33023 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33024 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33025 & NNCH(MSTR),IBHAD(MSTR),ISTR
33026
33027C count number of errors to avoid disk overflow
33028 DATA IERR / 0 /
33029
33030 IDEV = 0
33031C conservation check suppressed
33032 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33033
33034 IF(IPAMDL(13).GT.0) THEN
33035
33036C DPMJET call with x limitations
33037 MODE = -1
33038 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33039
33040 ELSE
33041
33042C standard call
33043 MODE = MD
33044C first two entries are considered as scattering particles
33045 EE1 = PHEP(4,1) + PHEP(4,2)
33046 PX1 = PHEP(1,1) + PHEP(1,2)
33047 PY1 = PHEP(2,1) + PHEP(2,2)
33048 PZ1 = PHEP(3,1) + PHEP(3,2)
33049
33050 ENDIF
33051
33052 DDREL = PARMDL(75)
33053 DDABS = PARMDL(76)
33054 IF(MODE.EQ.-1) GOTO 500
33055
33056 50 CONTINUE
33057
33058 I = 1
33059 100 CONTINUE
33060
33061C recognize only decayed particles as mothers
33062 IF(ISTHEP(I).EQ.2) THEN
33063C search for other mother particles
33064 K = JDAHEP(1,I)
33065 IF(K.EQ.0) THEN
33066 IF(IPAMDL(178).NE.0)
33067 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33068 & 'entry marked as decayed but no dauther given:',I
33069 GOTO 99
33070 ENDIF
33071 K1 = JMOHEP(1,K)
33072 K2 = JMOHEP(2,K)
33073C sum over mother particles
33074 ICH1 = IPHO_CHR3(K1,2)
33075 IBA1 = IPHO_BAR3(K1,2)
33076 EE1 = PHEP(4,K1)
33077 PX1 = PHEP(1,K1)
33078 PY1 = PHEP(2,K1)
33079 PZ1 = PHEP(3,K1)
33080 IF(K2.LT.0) THEN
33081 K2 = -K2
33082 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33083 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33084 & 'inconsistent mother/daughter relation found',I,K1,K2
33085 CALL PHO_PREVNT(-1)
33086 ENDIF
33087 DO 400 II=K1+1,K2
33088 IF(ABS(ISTHEP(II)).LE.2) THEN
33089 ICH1 = ICH1 + IPHO_CHR3(II,2)
33090 IBA1 = IBA1 + IPHO_BAR3(II,2)
33091 EE1 = EE1 + PHEP(4,II)
33092 PX1 = PX1 + PHEP(1,II)
33093 PY1 = PY1 + PHEP(2,II)
33094 PZ1 = PZ1 + PHEP(3,II)
33095 ENDIF
33096 400 CONTINUE
33097 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33098 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33099 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33100 EE1 = EE1 + PHEP(4,K2)
33101 PX1 = PX1 + PHEP(1,K2)
33102 PY1 = PY1 + PHEP(2,K2)
33103 PZ1 = PZ1 + PHEP(3,K2)
33104 ENDIF
33105
33106C sum over daughter particles
33107 ICH2 = 0.D0
33108 IBA2 = 0.D0
33109 EE2 = 0.D0
33110 PX2 = 0.D0
33111 PY2 = 0.D0
33112 PZ2 = 0.D0
33113 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33114 IF(ABS(ISTHEP(II)).LE.2) THEN
33115 ICH2 = ICH2 + IPHO_CHR3(II,2)
33116 IBA2 = IBA2 + IPHO_BAR3(II,2)
33117 EE2 = EE2 + PHEP(4,II)
33118 PX2 = PX2 + PHEP(1,II)
33119 PY2 = PY2 + PHEP(2,II)
33120 PZ2 = PZ2 + PHEP(3,II)
33121 ENDIF
33122 200 CONTINUE
33123
33124C conservation check
33125 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33126 IF(ABS(EE1-EE2).GT.ESC) THEN
33127 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33128 & 'PHO_CHECK: energy conservation violated for',
33129 & 'entry,initial,final:',I,EE1,EE2
33130 IDEV = 1
33131 ENDIF
33132 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33133 IF(ABS(PX1-PX2).GT.ESC) THEN
33134 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33135 & 'PHO_CHECK: x-momentum conservation violated for',
33136 & 'entry,initial,final:',I,PX1,PX2
33137 IDEV = 1
33138 ENDIF
33139 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33140 IF(ABS(PY1-PY2).GT.ESC) THEN
33141 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33142 & 'PHO_CHECK: y-momentum conservation violated for',
33143 & 'entry,initial,final:',I,PY1,PY2
33144 IDEV = 1
33145 ENDIF
33146 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33147 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33148 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33149 & 'PHO_CHECK: z-momentum conservation violated for',
33150 & 'entry,initial,final:',I,PZ1,PZ2
33151 IDEV = 1
33152 ENDIF
33153 IF(ICH1.NE.ICH2) THEN
33154 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33155 & 'PHO_CHECK: charge conservation violated for',
33156 & 'entry,initial,final:',I,ICH1,ICH2
33157 IDEV = 1
33158 ENDIF
33159 IF(IBA1.NE.IBA2) THEN
33160 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33161 & 'baryon charge conservation violated for',
33162 & 'entry,initial,final:',I,IBA1,IBA2
33163 IDEV = 1
33164 ENDIF
33165 IF(IDEB(20).GE.35) THEN
33166 WRITE(LO,
33167 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33168 & 'PHO_CHECK diagnostics:',
33169 & '(1.mother/l.mother,1.daughter/l.daughter):',
33170 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33171 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33172 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33173 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33174 ENDIF
33175 ENDIF
33176 99 CONTINUE
33177 I = I+1
33178 IF(I.LE.NHEP) GOTO 100
33179
33180 55 CONTINUE
33181
33182 IERR = IERR+IDEV
33183
33184C write complete event in case of deviations
33185 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33186 CALL PHO_PREVNT(1)
33187 IF(ISTR.GT.0) THEN
33188 CALL PHO_PRSTRG
33189 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33190 ENDIF
33191 ENDIF
33192
33193C stop after too many errors
33194 IF(IERR.GT.IPAMDL(179)) THEN
33195 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33196 & 'too many inconsistencies found, program terminated',IERR
33197 CALL PHO_ABORT
33198 ENDIF
33199
33200 RETURN
33201
33202C overall check only (less time consuming)
33203
33204 500 CONTINUE
33205
33206 ICH2 = 0.D0
33207 IBA2 = 0.D0
33208 EE2 = 0.D0
33209 PX2 = 0.D0
33210 PY2 = 0.D0
33211 PZ2 = 0.D0
33212
33213 DO 300 K=3,NHEP
33214C recognize only existing particles as possible daughters
33215 IF(ABS(ISTHEP(K)).EQ.1) THEN
33216 ICH2 = ICH2 + IPHO_CHR3(K,2)
33217 IBA2 = IBA2 + IPHO_BAR3(K,2)
33218 EE2 = EE2 + PHEP(4,K)
33219 PX2 = PX2 + PHEP(1,K)
33220 PY2 = PY2 + PHEP(2,K)
33221 PZ2 = PZ2 + PHEP(3,K)
33222 ENDIF
33223 300 CONTINUE
33224
33225C check energy-momentum conservation
33226 ESC = ECM*DDREL
33227
33228 IF(IPAMDL(13).GT.0) THEN
33229
33230C DPMJET call with x limitations
33231 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33232 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33233 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33234 & 'PHO_CHECK: c.m. energy conservation violated',
33235 & 'initial/final energy:',ECM1,ECM2
33236 IDEV = 1
33237 ENDIF
33238
33239 ELSE
33240
33241C standard call
33242 IF(ABS(EE1-EE2).GT.ESC) THEN
33243 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33244 & 'PHO_CHECK: energy conservation violated',
33245 & 'initial/final energy:',EE1,EE2
33246 IDEV = 1
33247 ENDIF
33248 IF(ABS(PX1-PX2).GT.ESC) THEN
33249 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33250 & 'PHO_CHECK: x-momentum conservation violated',
33251 & 'initial/final x-momentum:',PX1,PX2
33252 IDEV = 1
33253 ENDIF
33254 IF(ABS(PY1-PY2).GT.ESC) THEN
33255 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256 & 'PHO_CHECK: y-momentum conservation violated',
33257 & 'initial/final y-momentum:',PY1,PY2
33258 IDEV = 1
33259 ENDIF
33260 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33261 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33262 & 'PHO_CHECK: z-momentum conservation violated',
33263 & 'initial/final z-momentum:',PZ1,PZ2
33264 IDEV = 1
33265 ENDIF
33266
33267C check of quantum number conservation
33268
33269 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33270 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33271
33272 IF(ICH1.NE.ICH2) THEN
33273 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33274 & 'PHO_CHECK: charge conservation violated',
33275 & 'initial/final charge sum',ICH1,ICH2
33276 IDEV = 1
33277 ENDIF
33278 IF(IBA1.NE.IBA2) THEN
33279 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33280 & 'baryonic charge conservation violated',
33281 & 'initial/final baryonic charge sum',IBA1,IBA2
33282 IDEV = 1
33283 ENDIF
33284
33285 ENDIF
33286
33287C perform detailed checks in case of deviations
33288 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33289 IF(IPAMDL(13).GT.0) THEN
33290 GOTO 55
33291 ELSE
33292 DDREL = DDREL/2.D0
33293 DDABS = DDABS/2.D0
33294 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33295 & 'increasing precision of tests to',DDREL,DDABS
33296 GOTO 50
33297 ENDIF
33298 ENDIF
33299
33300 END
33301
33302*$ CREATE PHO_ABORT.FOR
33303*COPY PHO_ABORT
33304CDECK ID>, PHO_ABORT
33305 SUBROUTINE PHO_ABORT
33306C**********************************************************************
33307C
33308C top MC event generation due to fatal error,
33309C print all information of event generation and history
33310C
33311C**********************************************************************
33312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33313 SAVE
33314
33315C input/output channels
33316 INTEGER LI,LO
33317 COMMON /POINOU/ LI,LO
33318C event debugging information
33319 INTEGER NMAXD
33320 PARAMETER (NMAXD=100)
33321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33325C model switches and parameters
33326 CHARACTER*8 MDLNA
33327 INTEGER ISWMDL,IPAMDL
33328 DOUBLE PRECISION PARMDL
33329 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33330C standard particle data interface
33331 INTEGER NMXHEP
33332 PARAMETER (NMXHEP=4000)
33333 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33334 DOUBLE PRECISION PHEP,VHEP
33335 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33336 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33337 & VHEP(4,NMXHEP)
33338C extension to standard particle data interface (PHOJET specific)
33339 INTEGER IMPART,IPHIST,ICOLOR
33340 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33341C color string configurations including collapsed strings and hadrons
33342 INTEGER MSTR
33343 PARAMETER (MSTR=500)
33344 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33345 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33346 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33347 & NNCH(MSTR),IBHAD(MSTR),ISTR
33348C light-cone x fractions and c.m. momenta of soft cut string ends
33349 INTEGER MAXSOF
33350 PARAMETER ( MAXSOF = 50 )
33351 INTEGER IJSI2,IJSI1
33352 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33353 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33354 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33355 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33356C hard scattering data
33357 INTEGER MSCAHD
33358 PARAMETER ( MSCAHD = 50 )
33359 INTEGER LSCAHD,LSC1HD,LSIDX,
33360 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33361 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33362 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33363 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33364 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33365 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33366 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33367 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33368 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33369
33370 WRITE(LO,'(//,1X,A,/,1X,A)')
33371 & 'PHO_ABORT: program execution stopped',
33372 & '===================================='
33373 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33374C
33375 CALL PHO_SETMDL(0,0,-2)
33376 CALL PHO_PREVNT(-1)
33377 CALL PHO_ACTPDF(0,-2)
33378C print selected parton flavours
33379 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33380 DO 700 I=1,KSOFT
33381 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33382 700 CONTINUE
33383 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33384 DO 750 K=1,KHARD
33385 I = LSIDX(K)
33386 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33387 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33388 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33389 750 CONTINUE
33390C print selected parton momenta
33391 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33392 DO 300 I=1,KSOFT
33393 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33394 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33395 300 CONTINUE
33396 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33397 DO 350 K=1,KHARD
33398 I = LSIDX(K)
33399 I3 = 8*I-4
33400 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33401 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33402 350 CONTINUE
33403
33404C print /POEVT1/
33405 CALL PHO_PREVNT(0)
33406
33407C fragmentation process
33408 IF(ISTR.GT.0) THEN
33409C print /POSTRG/
33410 CALL PHO_PRSTRG
33411 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33412 ENDIF
33413
33414C last message
33415 WRITE(LO,'(////5X,A,///5X,A,///)')
33416 & 'PHO_ABORT: execution terminated due to fatal error',
33417 &'*** Simulating division by zero to get traceback information ***'
33418 ISTR = 100/IPAMDL(100)
33419
33420 END
33421
33422*$ CREATE PHO_TRACE.FOR
33423*COPY PHO_TRACE
33424CDECK ID>, PHO_TRACE
33425 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33426C**********************************************************************
33427C
33428C trace program subroutines according to level,
33429C original output levels will be saved
33430C
33431C input: ISTART first event to trace
33432C ISWI number of events to trace
33433C 0 loop call, use old values
33434C -1 restore original output levels
33435C 1 store level and wait for event
33436C LEVEL desired output level
33437C 0 standard output
33438C 3 internal rejections
33439C 5 cross sections, slopes etc.
33440C 10 parameter of subroutines and
33441C results
33442C 20 huge amount of debug output
33443C 30 maximal possible output
33444C
33445C**********************************************************************
33446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33447 SAVE
33448
33449C input/output channels
33450 INTEGER LI,LO
33451 COMMON /POINOU/ LI,LO
33452C event debugging information
33453 INTEGER NMAXD
33454 PARAMETER (NMAXD=100)
33455 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33456 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33457 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33458 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33459
33460 DIMENSION IMEM(NMAXD)
33461
33462C protect ISWI
33463 ISW = ISWI
33464 10 CONTINUE
33465 IF(ISW.EQ.0) THEN
33466 IF(KEVENT.LT.ION) THEN
33467 RETURN
33468 ELSE IF(KEVENT.EQ.ION) THEN
33469 WRITE(LO,'(///,1X,A,///)')
33470 & 'PHO_TRACE: trace mode switched on'
33471 DO 100 I=1,NMAXD
33472 IMEM(I) = IDEB(I)
33473 IDEB(I) = MAX(ILEVEL,IMEM(I))
33474 100 CONTINUE
33475 ELSE IF(KEVENT.EQ.IOFF) THEN
33476 WRITE(LO,'(//,1X,A,///)')
33477 & 'PHO_TRACE: trace mode switched off'
33478 DO 200 I=1,NMAXD
33479 IDEB(I) = IMEM(I)
33480 200 CONTINUE
33481 ENDIF
33482 ELSE IF(ISW.EQ.-1) THEN
33483 DO 300 I=1,NMAXD
33484 IDEB(I) = IMEM(I)
33485 300 CONTINUE
33486 ELSE
33487C save information
33488 ION = ISTART
33489 IOFF = ISTART+ISW
33490 ILEVEL = LEVEL
33491 ENDIF
33492C check coincidence
33493 IF(ISW.GT.0) THEN
33494 ISW=0
33495 ILEVEL = LEVEL
33496 GOTO 10
33497 ENDIF
33498
33499 END
33500
33501*$ CREATE PHO_PRSTRG.FOR
33502*COPY PHO_PRSTRG
33503CDECK ID>, PHO_PRSTRG
33504 SUBROUTINE PHO_PRSTRG
33505C**********************************************************************
33506C
33507C print information of /POSTRG/
33508C
33509C**********************************************************************
33510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33511 SAVE
33512
33513C input/output channels
33514 INTEGER LI,LO
33515 COMMON /POINOU/ LI,LO
33516C event debugging information
33517 INTEGER NMAXD
33518 PARAMETER (NMAXD=100)
33519 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33520 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33521 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33522 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33523C standard particle data interface
33524 INTEGER NMXHEP
33525 PARAMETER (NMXHEP=4000)
33526 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33527 DOUBLE PRECISION PHEP,VHEP
33528 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33529 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33530 & VHEP(4,NMXHEP)
33531C extension to standard particle data interface (PHOJET specific)
33532 INTEGER IMPART,IPHIST,ICOLOR
33533 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33534C color string configurations including collapsed strings and hadrons
33535 INTEGER MSTR
33536 PARAMETER (MSTR=500)
33537 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33538 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33539 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33540 & NNCH(MSTR),IBHAD(MSTR),ISTR
33541
33542 WRITE(LO,'(/,1X,A,I5)')
33543 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33544 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33545 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33546 WRITE(LO,'(1X,A)')
33547 & ' ======================================================='
33548 DO 800 I=1,ISTR
33549 WRITE(LO,'(1X,9I5,1P,E11.3)')
33550 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33551 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33552 800 CONTINUE
33553
33554 END
33555
33556*$ CREATE PHO_PREVNT.FOR
33557*COPY PHO_PREVNT
33558CDECK ID>, PHO_PREVNT
33559 SUBROUTINE PHO_PREVNT(NPART)
33560C**********************************************************************
33561C
33562C print all information of event generation and history
33563C
33564C input: NPART -1 minimal output: process IDs
33565C 0 additional output of /POEVT1/
33566C 1 additional output of /POSTRG/
33567C 2 additional output of /HEPEVT/
33568C (call LULIST(1))
33569C
33570C**********************************************************************
33571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33572 SAVE
33573
33574C input/output channels
33575 INTEGER LI,LO
33576 COMMON /POINOU/ LI,LO
33577C event debugging information
33578 INTEGER NMAXD
33579 PARAMETER (NMAXD=100)
33580 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33581 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33582 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33583 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33584C model switches and parameters
33585 CHARACTER*8 MDLNA
33586 INTEGER ISWMDL,IPAMDL
33587 DOUBLE PRECISION PARMDL
33588 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33589C global event kinematics and particle IDs
33590 INTEGER IFPAP,IFPAB
33591 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33592 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33593C general process information
33594 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33595 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33596C standard particle data interface
33597 INTEGER NMXHEP
33598 PARAMETER (NMXHEP=4000)
33599 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33600 DOUBLE PRECISION PHEP,VHEP
33601 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33602 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33603 & VHEP(4,NMXHEP)
33604C extension to standard particle data interface (PHOJET specific)
33605 INTEGER IMPART,IPHIST,ICOLOR
33606 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33607C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33608 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33609 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33610 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33611 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33612
33613 CHARACTER*15 PHO_PNAME
33614
33615 IF(NPART.GE.0) WRITE(LO,'(/)')
33616 WRITE(LO,'(1X,A,1PE10.3)')
33617 & 'PHO_PREVNT: c.m. energy',ECM
33618 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33619 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33620 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33621 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33622 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33623 & KHDPO
33624 WRITE(LO,'(6X,A,I4,4I3)')
33625 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33626 & IDIFR2,IDDPOM
33627
33628 IF(IPAMDL(13).GT.0) THEN
33629 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33630 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33631 & ECMN,PCMN,SECM,SPCM
33632 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33633 ENDIF
33634
33635 IF(NPART.LT.0) RETURN
33636
33637 IF(NPART.GE.1) CALL PHO_PRSTRG
33638
33639 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33640 ICHAS = 0
33641 IBARFS = 0
33642 IMULC = 0
33643 IMUL = 0
33644 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33645 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33646 & ' IH1 IH2 CO1 CO2',
33647 & '========================================================',
33648 & '===================='
33649 DO 20 IH=1,NHEP
33650 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33651 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33652 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33653 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33654 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33655 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33656 & ICOLOR(1,IH),ICOLOR(2,IH)
33657 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33658 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33659 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33660 ENDIF
33661 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33662 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33663 IMUL = IMUL+1
33664 ENDIF
33665 20 CONTINUE
33666 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33667 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33668
33669 WRITE(LO,7)
33670 PXS = 0.D0
33671 PYS = 0.D0
33672 PZS = 0.D0
33673 P0S = 0.D0
33674 DO 30 IN=1,NHEP
33675 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33676 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33677 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33678 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33679 ELSE
33680 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33681 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33682 ENDIF
33683 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33684 PXS = PXS + PHEP(1,IN)
33685 PYS = PYS + PHEP(2,IN)
33686 PZS = PZS + PHEP(3,IN)
33687 P0S = P0S + PHEP(4,IN)
33688 ENDIF
33689 30 CONTINUE
33690 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33691 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33692 IF(P0S.LT.99999.D0) THEN
33693 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33694 ELSE
33695 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33696 ENDIF
33697 WRITE(LO,'(//)')
33698
33699 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33700 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33701 & 8H CHARGE ,8H BARYON ,/)
33702 6 FORMAT(7I8,2F8.3)
33703 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33704 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33705 & 2X,'-------------------------------',
33706 & '--------------------------------------------')
33707 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33708 9 FORMAT(I10,14X,5F10.3)
33709 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33710 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33711 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33712
33713 IF(NPART.GE.2) CALL PYLIST(1)
33714
33715 END
33716
33717*$ CREATE PHO_LTRHEP.FOR
33718*COPY PHO_LTRHEP
33719CDECK ID>, PHO_LTRHEP
33720 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33721C*******************************************************************
33722C
33723C Lorentz transformation of entries I1 to I2 in /POEVT1/
33724C
33725C********************************************************************
33726 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33727 SAVE
33728
33729 PARAMETER ( DIFF = 0.001D0,
33730 & EPS = 1.D-5 )
33731
33732C input/output channels
33733 INTEGER LI,LO
33734 COMMON /POINOU/ LI,LO
33735C event debugging information
33736 INTEGER NMAXD
33737 PARAMETER (NMAXD=100)
33738 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33739 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33740 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33741 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33742C standard particle data interface
33743 INTEGER NMXHEP
33744 PARAMETER (NMXHEP=4000)
33745 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33746 DOUBLE PRECISION PHEP,VHEP
33747 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33748 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33749 & VHEP(4,NMXHEP)
33750C extension to standard particle data interface (PHOJET specific)
33751 INTEGER IMPART,IPHIST,ICOLOR
33752 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33753
33754 DO 100 I=I1,MIN(I2,NHEP)
33755 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33756 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33757 & XX,YY,ZZ)
33758 EE=PHEP(4,I)
33759 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33760 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33761 ELSE IF(ISTHEP(I).EQ.20) THEN
33762 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33763 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33764 & XX,YY,ZZ)
33765 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33766 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33767 ENDIF
33768 100 CONTINUE
33769
33770C debug precision
33771 IF(IDEB(70).LT.1) RETURN
33772 DO 200 I=I1,MIN(NHEP,I2)
33773 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33774 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33775 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33776 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33777 WRITE(LO,'(1X,A,I5,2E13.4)')
33778 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33779 ENDIF
33780 190 CONTINUE
33781 200 CONTINUE
33782
33783 END
33784
33785*$ CREATE PHO_PECMS.FOR
33786*COPY PHO_PECMS
33787CDECK ID>, PHO_PECMS
33788 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33789C*******************************************************************
33790C
33791C calculation of cms momentum and energy of massive particle
33792C (ID= 1 using PMASS1, 2 using PMASS2)
33793C
33794C output: PP cms momentum
33795C EE energy in CMS of particle ID
33796C
33797C********************************************************************
33798 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33799 SAVE
33800
33801C input/output channels
33802 INTEGER LI,LO
33803 COMMON /POINOU/ LI,LO
33804C event debugging information
33805 INTEGER NMAXD
33806 PARAMETER (NMAXD=100)
33807 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33808 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33809 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33810 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33811C some constants
33812 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33813 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33814 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33815
33816 S=ECM**2
33817 PM1 = SIGN(PMASS1**2,PMASS1)
33818 PM2 = SIGN(PMASS2**2,PMASS2)
33819 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33820 & + PM1**2 + PM2**2)/(2.D0*ECM)
33821
33822 IF(ID.EQ.1) THEN
33823 EE = SQRT( PM1 + PP**2 )
33824 ELSE IF(ID.EQ.2) THEN
33825 EE = SQRT( PM2 + PP**2 )
33826 ELSE
33827 WRITE(LO,'(/1X,A,I3,/)')
33828 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33829 EE = PP
33830 ENDIF
33831
33832 END
33833
33834*$ CREATE PHO_FRAINI.FOR
33835*COPY PHO_FRAINI
33836CDECK ID>, PHO_FRAINI
33837 SUBROUTINE PHO_FRAINI(IDEFAU)
33838C***********************************************************************
33839C
33840C initialization of fragmentation packages
33841C (currently LUND JETSET)
33842C
33843C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33844C changed to work in PHOJET (R.E. 1/94)
33845C
33846C input: IDEFAU 0 no hadronization at all
33847C 1 do not touch any parameter of JETSET
33848C 2 default parameters kept, decay length 10mm to
33849C define stable particles
33850C 3 load tuned parameters for JETSET 7.3
33851C neg. value: prevent strange/charm hadrons from decaying
33852C
33853C***********************************************************************
33854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33855 SAVE
33856
33857 PARAMETER (EPS=1.D-10)
33858
33859C input/output channels
33860 INTEGER LI,LO
33861 COMMON /POINOU/ LI,LO
33862 INTEGER N,NPAD,K
33863 DOUBLE PRECISION P,V
33864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33865 INTEGER MSTU,MSTJ
33866 DOUBLE PRECISION PARU,PARJ
33867 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33868 INTEGER KCHG
33869 DOUBLE PRECISION PMAS,PARF,VCKM
33870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33871 INTEGER MDCY,MDME,KFDP
33872 DOUBLE PRECISION BRAT
bd378884 33873 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 33874
33875 INTEGER PYCOMP
33876
33877 IDEFAB = ABS(IDEFAU)
33878
33879 IF(IDEFAB.EQ.0) THEN
33880 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33881 RETURN
33882 ENDIF
33883C defaults
33884 DEF2 = PARJ(2)
33885 IDEF12 = MSTJ(12)
33886 DEF19 = PARJ(19)
33887 DEF41 = PARJ(41)
33888 DEF42 = PARJ(42)
33889 DEF21 = PARJ(21)
33890
33891C declare stable particles
1ddc441c 33892c IF(IDEFAB.GE.2) MSTJ(22) = 2
9aaba0d6 33893
33894C load optimized parameters
33895 IF(IDEFAB.GE.3) THEN
33896* PARJ(19)=0.19
33897C Lund a-parameter
33898C (default=0.3)
33899 PARJ(41)=0.3
33900C Lund b-parameter
33901C (default=1.0)
33902 PARJ(42)=1.0
33903C Lund sigma parameter in pt distribution
33904C (default=0.36)
33905 PARJ(21)=0.36
33906 ENDIF
33907C
33908C prevent particles decaying
33909 IF(IDEFAU.LT.0) THEN
33910C K0S
33911 KC=PYCOMP(310)
33912 MDCY(KC,1)=0
33913C PI0
33914 KC=PYCOMP(111)
33915 MDCY(KC,1)=0
33916C LAMBDA
33917 KC=PYCOMP(3122)
33918 MDCY(KC,1)=0
33919C ALAMBDA
33920 KC=PYCOMP(-3122)
33921 MDCY(KC,1)=0
33922C SIG+
33923 KC=PYCOMP(3222)
33924 MDCY(KC,1)=0
33925C ASIG+
33926 KC=PYCOMP(-3222)
33927 MDCY(KC,1)=0
33928C SIG-
33929 KC=PYCOMP(3112)
33930 MDCY(KC,1)=0
33931C ASIG-
33932 KC=PYCOMP(-3112)
33933 MDCY(KC,1)=0
33934C SIG0
33935 KC=PYCOMP(3212)
33936 MDCY(KC,1)=0
33937C ASIG0
33938 KC=PYCOMP(-3212)
33939 MDCY(KC,1)=0
33940C TET0
33941 KC=PYCOMP(3322)
33942 MDCY(KC,1)=0
33943C ATET0
33944 KC=PYCOMP(-3322)
33945 MDCY(KC,1)=0
33946C TET-
33947 KC=PYCOMP(3312)
33948 MDCY(KC,1)=0
33949C ATET-
33950 KC=PYCOMP(-3312)
33951 MDCY(KC,1)=0
33952C OMEGA-
33953 KC=PYCOMP(3334)
33954 MDCY(KC,1)=0
33955C AOMEGA-
33956 KC=PYCOMP(-3334)
33957 MDCY(KC,1)=0
33958C D+
33959 KC=PYCOMP(411)
33960 MDCY(KC,1)=0
33961C D-
33962 KC=PYCOMP(-411)
33963 MDCY(KC,1)=0
33964C D0
33965 KC=PYCOMP(421)
33966 MDCY(KC,1)=0
33967C A-D0
33968 KC=PYCOMP(-421)
33969 MDCY(KC,1)=0
33970C DS+
33971 KC=PYCOMP(431)
33972 MDCY(KC,1)=0
33973C A-DS+
33974 KC=PYCOMP(-431)
33975 MDCY(KC,1)=0
33976C ETAC
33977 KC=PYCOMP(441)
33978 MDCY(KC,1)=0
33979C LAMBDAC+
33980 KC=PYCOMP(4122)
33981 MDCY(KC,1)=0
33982C A-LAMBDAC+
33983 KC=PYCOMP(-4122)
33984 MDCY(KC,1)=0
33985C SIGMAC++
33986 KC=PYCOMP(4222)
33987 MDCY(KC,1)=0
33988C SIGMAC+
33989 KC=PYCOMP(4212)
33990 MDCY(KC,1)=0
33991C SIGMAC0
33992 KC=PYCOMP(4112)
33993 MDCY(KC,1)=0
33994C A-SIGMAC++
33995 KC=PYCOMP(-4222)
33996 MDCY(KC,1)=0
33997C A-SIGMAC+
33998 KC=PYCOMP(-4212)
33999 MDCY(KC,1)=0
34000C A-SIGMAC0
34001 KC=PYCOMP(-4112)
34002 MDCY(KC,1)=0
34003C KSIC+
34004 KC=PYCOMP(4232)
34005 MDCY(KC,1)=0
34006C KSIC0
34007 KC=PYCOMP(4132)
34008 MDCY(KC,1)=0
34009C A-KSIC+
34010 KC=PYCOMP(-4232)
34011 MDCY(KC,1)=0
34012C A-KSIC0
34013 KC=PYCOMP(-4132)
34014 MDCY(KC,1)=0
34015 ENDIF
34016
34017 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34018 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34019 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34020 & ' --------------------------------------------------',/,
34021 & 5X,'parameter description default / current',/,
34022 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34023 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34024 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34025 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34026 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34027 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34028
34029 END
34030
34031*$ CREATE PHO_SETPAR.FOR
34032*COPY PHO_SETPAR
34033CDECK ID>, PHO_SETPAR
34034 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34035C**********************************************************************
34036C
34037C assign a particle to either side 1 or 2
34038C (including special treatment for remnants)
34039C
34040C input: Iside 1,2 side selected for the particle
34041C -2 output of current settings
34042C IDpdg PDG number
34043C IDcpc CPC number
34044C 0 CPC determination in subroutine
34045C -1 special particle remnant, IDPDG
34046C is the particle number the remnant
34047C corresponds to (see /POHDFL/)
34048C
34049C**********************************************************************
34050 IMPLICIT NONE
34051 SAVE
34052
34053 integer Iside,IDpdg,IDcpc
34054 double precision Pvir
34055
34056C input/output channels
34057 INTEGER LI,LO
34058 COMMON /POINOU/ LI,LO
34059C event debugging information
34060 INTEGER NMAXD
34061 PARAMETER (NMAXD=100)
34062 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34063 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34064 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34065 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34066C global event kinematics and particle IDs
34067 INTEGER IFPAP,IFPAB
34068 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34069 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34070C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34071 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34072 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34073 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34074 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34075C particle ID translation table
34076 integer ID_pdg_list,ID_list,ID_pdg_max
34077 character*12 name_list
34078 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34079 & ID_pdg_max
34080C general particle data
34081 double precision xm_list,tau_list,gam_list,
34082 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34083 & xm_bb82_list,xm_bb102_list
34084 integer ich3_list,iba3_list,iq_list,
34085 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34086 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34087 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34088 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34089 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34090 & ich3_list(300),iba3_list(300),iq_list(3,300),
34091 & id_psm_list(6,6),id_vem_list(6,6),
34092 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34093C particle decay data
34094 double precision wg_sec_list
34095 integer idec_list,isec_list
34096 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34097 & isec_list(3,500)
34098
34099C external functions
34100 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34101 double precision pho_pmass
34102
34103C local variables
34104 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34105
34106 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34107 IDcpcN = IDcpc
34108C remnant?
34109 IF(IDcpc.EQ.-1) THEN
34110 IF(Iside.EQ.1) THEN
34111 IDpdgR = 81
34112 ELSE
34113 IDpdgR = 82
34114 ENDIF
34115 IDcpcR = ipho_pdg2id(IDpdgR)
34116 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34117 IDEQP(Iside) = IDpdg
34118C copy particle properties
34119 IDB = abs(IDEQB(Iside))
34120 xm_list(IDcpcR) = xm_list(IDB)
34121 tau_list(IDcpcR) = tau_list(IDB)
34122 gam_list(IDcpcR) = gam_list(IDB)
34123 IF(IHFLS(Iside).EQ.1) THEN
34124 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34125 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34126 ELSE
34127 ich3_list(IDcpcR) = 0
34128 iba3_list(IDcpcR) = 0
34129 ENDIF
34130C quark content
34131 IFL1 = IHFLD(Iside,1)
34132 IFL2 = IHFLD(Iside,2)
34133 IFL3 = 0
34134 IF(IHFLS(Iside).EQ.1) THEN
34135 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34136 IFL1 = IHFLD(Iside,1)/1000
34137 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34138 IFL3 = IHFLD(Iside,2)
34139 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34140 IFL1 = IHFLD(Iside,1)
34141 IFL2 = IHFLD(Iside,2)/1000
34142 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34143 ENDIF
34144 ENDIF
34145 iq_list(1,IDcpcR) = IFL1
34146 iq_list(2,IDcpcR) = IFL2
34147 iq_list(3,IDcpcR) = IFL3
34148
34149 IDcpcN = IDcpcR
34150 IDPDGN = IDPDGR
34151
34152 IF(IDEB(87).GE.5) THEN
34153 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34154 & 'pho_setpar: remnant assignment side',Iside,
34155 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34156 ENDIF
34157 ELSE IF(IDcpc.EQ.0) THEN
34158C ordinary hadron
34159 IHFLS(Iside) = 1
34160 IHFLD(Iside,1) = 0
34161 IHFLD(Iside,2) = 0
34162 IDcpcN = ipho_pdg2id(IDpdg)
34163 IDpdgN = IDpdg
34164 ENDIF
34165
34166C initialize /POGCMS/
34167 IFPAP(Iside) = IDpdgN
34168 IFPAB(Iside) = IDcpcN
34169 PMASS(Iside) = pho_pmass(IDcpcN,0)
34170 IF(IFPAP(Iside).EQ.22) THEN
34171 PVIRT(Iside) = ABS(PVIR)
34172 ELSE
34173 PVIRT(Iside) = 0.D0
34174 ENDIF
34175
34176 ELSE IF(Iside.EQ.-2) THEN
34177C output of current settings
34178 DO 100 I=1,2
34179 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34180 & 'PHO_SETPAR: side',
34181 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34182 & PVIRT(I)
34183 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34184 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34185 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34186 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34187 ENDIF
34188 100 CONTINUE
34189 ELSE
34190 WRITE(LO,'(/1X,A,I8)')
34191 & 'pho_setpar: invalid argument (Iside)',Iside
34192 ENDIF
34193
34194 END
34195
34196*$ CREATE PHO_XLAM.FOR
34197*COPY PHO_XLAM
34198CDECK ID>, PHO_XLAM
34199 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34200C**********************************************************************
34201C
34202C auxiliary function for two/three particle decay mode
34203C (standard LAMBDA**(1/2) function)
34204C
34205C**********************************************************************
34206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34207 SAVE
34208C
34209 YZ=Y-Z
34210 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34211 IF(XLAM.LT.0.D0) XLAM=-XLAM
34212 PHO_XLAM=SQRT(XLAM)
34213 END
34214
34215*$ CREATE PHO_BESSJ0.FOR
34216*COPY PHO_BESSJ0
34217CDECK ID>, PHO_BESSJ0
34218 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34219C**********************************************************************
34220C
34221C CERN (KERN) LIB function C312
34222C
34223C modified by R. Engel (03/02/93)
34224C
34225C**********************************************************************
34226 DOUBLE PRECISION DX
34227 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34228 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34229 SAVE
34230
34231 DATA EIGHT /8.0D0/
34232 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34233
34234 DATA C1( 0) /+0.15772 79714 7489D0/
34235 DATA C1( 1) /-0.00872 34423 5285D0/
34236 DATA C1( 2) /+0.26517 86132 0334D0/
34237 DATA C1( 3) /-0.37009 49938 7265D0/
34238 DATA C1( 4) /+0.15806 71023 3210D0/
34239 DATA C1( 5) /-0.03489 37694 1141D0/
34240 DATA C1( 6) /+0.00481 91800 6947D0/
34241 DATA C1( 7) /-0.00046 06261 6621D0/
34242 DATA C1( 8) /+0.00003 24603 2882D0/
34243 DATA C1( 9) /-0.00000 17619 4691D0/
34244 DATA C1(10) /+0.00000 00760 8164D0/
34245 DATA C1(11) /-0.00000 00026 7925D0/
34246 DATA C1(12) /+0.00000 00000 7849D0/
34247 DATA C1(13) /-0.00000 00000 0194D0/
34248 DATA C1(14) /+0.00000 00000 0004D0/
34249
34250 DATA C2( 0) /+0.99946 03493 4752D0/
34251 DATA C2( 1) /-0.00053 65220 4681D0/
34252 DATA C2( 2) /+0.00000 30751 8479D0/
34253 DATA C2( 3) /-0.00000 00517 0595D0/
34254 DATA C2( 4) /+0.00000 00016 3065D0/
34255 DATA C2( 5) /-0.00000 00000 7864D0/
34256 DATA C2( 6) /+0.00000 00000 0517D0/
34257 DATA C2( 7) /-0.00000 00000 0043D0/
34258 DATA C2( 8) /+0.00000 00000 0004D0/
34259 DATA C2( 9) /-0.00000 00000 0001D0/
34260
34261 DATA C3( 0) /-0.01555 58546 05337D0/
34262 DATA C3( 1) /+0.00006 83851 99426D0/
34263 DATA C3( 2) /-0.00000 07414 49841D0/
34264 DATA C3( 3) /+0.00000 00179 72457D0/
34265 DATA C3( 4) /-0.00000 00007 27192D0/
34266 DATA C3( 5) /+0.00000 00000 42201D0/
34267 DATA C3( 6) /-0.00000 00000 03207D0/
34268 DATA C3( 7) /+0.00000 00000 00301D0/
34269 DATA C3( 8) /-0.00000 00000 00033D0/
34270 DATA C3( 9) /+0.00000 00000 00004D0/
34271 DATA C3(10) /-0.00000 00000 00001D0/
34272
34273 X=DX
34274 V=ABS(X)
34275 IF(V .LT. EIGHT) THEN
34276 Y=V/EIGHT
34277 H=2.D0*Y**2-1.D0
34278 ALFA=-2.D0*H
34279 B1=0.D0
34280 B2=0.D0
34281 DO 1 I = 14,0,-1
34282 B0=C1(I)-ALFA*B1-B2
34283 B2=B1
34284 1 B1=B0
34285 B1=B0-H*B2
34286 ELSE
34287 R=1.D0/V
34288 Y=EIGHT*R
34289 H=2.D0*Y**2-1.D0
34290 ALFA=-2.D0*H
34291 B1=0.D0
34292 B2=0.D0
34293 DO 2 I = 9,0,-1
34294 B0=C2(I)-ALFA*B1-B2
34295 B2=B1
34296 2 B1=B0
34297 P=B0-H*B2
34298 B1=0.D0
34299 B2=0.D0
34300 DO 3 I = 10,0,-1
34301 B0=C3(I)-ALFA*B1-B2
34302 B2=B1
34303 3 B1=B0
34304 Q=Y*(B0-H*B2)
34305 B0=V-PI2
34306 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34307 ENDIF
34308 PHO_BESSJ0=B1
34309 RETURN
34310 END
34311
34312*$ CREATE PHO_BESSI0.FOR
34313*COPY PHO_BESSI0
34314CDECK ID>, PHO_BESSI0
34315 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34316C**********************************************************************
34317C
34318C Bessel Function I0
34319C
34320C**********************************************************************
34321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34322 SAVE
34323
34324 AX = ABS(X)
34325 IF (AX .LT. 3.75D0) THEN
34326 Y = (X/3.75D0)**2
34327 PHO_BESSI0 =
34328 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34329 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34330 ELSE
34331 Y = 3.75D0/AX
34332 PHO_BESSI0 =
34333 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34334 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34335 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34336 & +Y*0.392377D-2))))))))
34337 ENDIF
34338
34339 END
34340
34341*$ CREATE PHO_BESSI1.FOR
34342*COPY PHO_BESSI1
34343CDECK ID>, PHO_BESSI1
34344 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34345C**********************************************************************
34346C
34347C Bessel Function I1
34348C
34349C**********************************************************************
34350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34351 SAVE
34352
34353 AX = ABS(X)
34354
34355 IF (AX .LT. 3.75D0) THEN
34356 Y = (X/3.75D0)**2
34357 BESLI1 =
34358 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34359 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34360 ELSE
34361 Y = 3.75D0/AX
34362 BESLI1 =
34363 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34364 & -Y*0.420059D-2))
34365 BESLI1 =
34366 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34367 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34368 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34369 ENDIF
34370 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34371
34372 PHO_BESSI1 = BESLI1
34373
34374 END
34375
34376*$ CREATE PHO_BESSK0.FOR
34377*COPY PHO_BESSK0
34378CDECK ID>, PHO_BESSK0
34379 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34380C**********************************************************************
34381C
34382C Modified Bessel Function K0
34383C
34384C**********************************************************************
34385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34386 SAVE
34387
34388 IF (X .LT. 2.D0) THEN
34389 Y = X**2/4.D0
34390 PHO_BESSK0 =
34391 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34392 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34393 & +Y*(0.10750D-3+Y*0.740D-5))))))
34394 ELSE
34395 Y = 2.D0/X
34396 PHO_BESSK0 =
34397 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34398 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34399 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34400 ENDIF
34401
34402 END
34403
34404*$ CREATE PHO_BESSK1.FOR
34405*COPY PHO_BESSK1
34406CDECK ID>, PHO_BESSK1
34407 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34408C**********************************************************************
34409C
34410C Modified Bessel Function K1
34411C
34412C**********************************************************************
34413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34414 SAVE
34415
34416 IF (X .LT. 2.D0) THEN
34417 Y = X**2/4.D0
34418 PHO_BESSK1 =
34419 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34420 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34421 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34422 ELSE
34423 Y=2.D0/X
34424 PHO_BESSK1 =
34425 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34426 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34427 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34428 ENDIF
34429
34430 END
34431
34432*$ CREATE PHO_GAUSET.FOR
34433*COPY PHO_GAUSET
34434CDECK ID>, PHO_GAUSET
34435 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34436C********************************************************************
34437C
34438C N-point gauss zeros and weights for the interval (AX,BX) are
34439C stored in arrays Z and W respectively.
34440C
34441C*********************************************************************
34442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34443 SAVE
34444
34445 COMMON /POGDAT/A(273),X(273),KTAB(96)
34446 DIMENSION Z(NX),W(NX)
34447
34448 ALPHA=0.5*(BX+AX)
34449 BETA=0.5*(BX-AX)
34450 N=NX
34451
34452C the N=1 case:
34453 IF(N.NE.1) GO TO 1
34454 Z(1)=ALPHA
34455 W(1)=BX-AX
34456 RETURN
34457
34458C the Gauss cases:
34459 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34460 IF(N.EQ.20) GO TO 2
34461 IF(N.EQ.24) GO TO 2
34462 IF(N.EQ.32) GO TO 2
34463 IF(N.EQ.40) GO TO 2
34464 IF(N.EQ.48) GO TO 2
34465 IF(N.EQ.64) GO TO 2
34466 IF(N.EQ.80) GO TO 2
34467 IF(N.EQ.96) GO TO 2
34468
34469C the extended Gauss cases:
34470 IF((N/96)*96.EQ.N) GO TO 3
34471
34472C jump to center of intervall intrgration:
34473 GO TO 100
34474
34475C get Gauss point array
34476
34477 2 CALL PHO_GAUDAT
34478C extract real points
34479 K=KTAB(N)
34480 M=N/2
34481 DO 21 J=1,M
34482C extract values from big array
34483 JTAB=K-1+J
34484 WTEMP=BETA*A(JTAB)
34485 DELTA=BETA*X(JTAB)
34486C store them backward
34487 Z(J)=ALPHA-DELTA
34488 W(J)=WTEMP
34489C store them forward
34490 JP=N+1-J
34491 Z(JP)=ALPHA+DELTA
34492 W(JP)=WTEMP
34493 21 CONTINUE
34494C store central point (odd N)
34495 IF((N-M-M).EQ.0) RETURN
34496 Z(M+1)=ALPHA
34497 JMID=K+M
34498 W(M+1)=BETA*A(JMID)
34499 RETURN
34500
34501C get ND96 times chained 96 Gauss point array
34502
34503 3 CALL PHO_GAUDAT
34504C print out message
34505C -extract real points
34506 K=KTAB(96)
34507 ND96=N/96
34508 DO 31 J=1,48
34509C extract values from big array
34510 JTAB=K-1+J
34511 WTEMP=BETA*A(JTAB)
34512 DELTA=BETA*X(JTAB)
34513 WTeMP=WTEMP/ND96
34514 DeLTA=DELTA/ND96
34515 DO 32 JD96=0,ND96-1
34516 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34517C store them backward
34518 Z(J+JD96*96)=ZCNTR-DELTA
34519 W(J+JD96*96)=WTEMP
34520C store them forward
34521 JP=96+1-J
34522 Z(JP+JD96*96)=ZCNTR+DELTA
34523 W(JP+JD96*96)=WTEMP
34524 32 CONTINUE
34525 31 CONTINUE
34526 RETURN
34527
34528C the center of intervall cases:
34529 100 CONTINUE
34530C put in constant weight and equally spaced central points
34531 N=IABS(N)
34532 DO 111 IN=1,N
34533 WIN=(BX-AX)/FLOAT(N)
34534 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34535 111 W(IN)=WIN
34536
34537 END
34538
34539*$ CREATE PHO_GAUDAT.FOR
34540*COPY PHO_GAUDAT
34541CDECK ID>, PHO_GAUDAT
34542 SUBROUTINE PHO_GAUDAT
34543C*********************************************************************
34544C
34545C store big arrays needed for Gauss integral, CERNLIB D106BD
34546C (arrays A,X,ITAB copied on B,Y,LTAB)
34547C
34548C*********************************************************************
34549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34550
34551 SAVE
34552 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34553 DIMENSION A(273),X(273),KTAB(96)
34554
34555C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34556 DATA KTAB(2)/1/
34557 DATA KTAB(3)/2/
34558 DATA KTAB(4)/4/
34559 DATA KTAB(5)/6/
34560 DATA KTAB(6)/9/
34561 DATA KTAB(7)/12/
34562 DATA KTAB(8)/16/
34563 DATA KTAB(9)/20/
34564 DATA KTAB(10)/25/
34565 DATA KTAB(11)/30/
34566 DATA KTAB(12)/36/
34567 DATA KTAB(13)/42/
34568 DATA KTAB(14)/49/
34569 DATA KTAB(15)/56/
34570 DATA KTAB(16)/64/
34571 DATA KTAB(20)/72/
34572 DATA KTAB(24)/82/
34573 DATA KTAB(28)/82/
34574 DATA KTAB(32)/94/
34575 DATA KTAB(36)/94/
34576 DATA KTAB(40)/110/
34577 DATA KTAB(44)/110/
34578 DATA KTAB(48)/130/
34579 DATA KTAB(52)/130/
34580 DATA KTAB(56)/130/
34581 DATA KTAB(60)/130/
34582 DATA KTAB(64)/154/
34583 DATA KTAB(68)/154/
34584 DATA KTAB(72)/154/
34585 DATA KTAB(76)/154/
34586 DATA KTAB(80)/186/
34587 DATA KTAB(84)/186/
34588 DATA KTAB(88)/186/
34589 DATA KTAB(92)/186/
34590 DATA KTAB(96)/226/
34591C
34592C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34593C
34594C-----N=2
34595 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34596C-----N=3
34597 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34598 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34599C-----N=4
34600 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34601 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34602C-----N=5
34603 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34604 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34605 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34606C-----N=6
34607 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34608 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34609 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34610C-----N=7
34611 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34612 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34613 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34614 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34615C-----N=8
34616 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34617 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34618 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34619 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34620C-----N=9
34621 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34622 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34623 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34624 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34625 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34626C-----N=10
34627 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34628 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34629 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34630 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34631 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34632C-----N=11
34633 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34634 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34635 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34636 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34637 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34638 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34639C-----N=12
34640 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34641 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34642 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34643 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34644 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34645 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34646C-----N=13
34647 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34648 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34649 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34650 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34651 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34652 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34653 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34654C-----N=14
34655 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34656 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34657 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34658 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34659 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34660 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34661 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34662C-----N=15
34663 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34664 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34665 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34666 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34667 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34668 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34669 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34670 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34671C-----N=16
34672 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34673 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34674 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34675 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34676 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34677 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34678 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34679 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34680C-----N=20
34681 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34682 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34683 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34684 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34685 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34686 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34687 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34688 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34689 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34690 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34691C-----N=24
34692 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34693 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34694 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34695 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34696 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34697 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34698 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34699 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34700 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34701 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34702 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34703 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34704C-----N=32
34705 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34706 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34707 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34708 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34709 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34710 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34711 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34712 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34713 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34714 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34715 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34716 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34717 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34718 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34719 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34720 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34721C-----N=40
34722 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34723 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34724 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34725 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34726 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34727 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34728 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34729 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34730 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34731 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34732 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34733 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34734 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34735 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34736 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34737 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34738 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34739 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34740 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34741 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34742C-----N=48
34743 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34744 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34745 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34746 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34747 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34748 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34749 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34750 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34751 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34752 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34753 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34754 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34755 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34756 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34757 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34758 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34759 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34760 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34761 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34762 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34763 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34764 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34765 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34766 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34767C-----N=64
34768 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34769 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34770 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34771 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34772 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34773 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34774 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34775 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34776 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34777 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34778 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34779 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34780 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34781 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34782 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34783 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34784 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34785 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34786 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34787 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34788 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34789 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34790 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34791 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34792 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34793 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34794 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34795 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34796 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34797 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34798 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34799 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34800C-----N=80
34801 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34802 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34803 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34804 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34805 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34806 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34807 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34808 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34809 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34810 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34811 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34812 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34813 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34814 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34815 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34816 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34817 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34818 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34819 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34820 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34821 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34822 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34823 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34824 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34825 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34826 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34827 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34828 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34829 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34830 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34831 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34832 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34833 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34834 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34835 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34836 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34837 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34838 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34839 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34840 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34841C-----N=96
34842 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34843 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34844 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34845 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34846 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34847 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34848 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34849 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34850 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34851 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34852 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34853 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34854 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34855 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34856 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34857 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34858 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34859 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34860 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34861 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34862 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34863 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34864 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34865 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34866 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34867 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34868 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34869 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34870 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34871 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34872 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34873 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34874 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34875 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34876 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34877 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34878 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34879 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34880 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34881 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34882 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34883 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34884 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34885 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34886 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34887 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34888 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34889 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34890 DATA IBD/0/
34891 IF(IBD.NE.0) RETURN
34892 IBD=1
34893 DO 10 I=1,273
34894 B(I) = A(I)
34895 Y(I) = X(I)
34896 10 CONTINUE
34897 DO 20 I=1,96
34898 LTAB(I) = KTAB(I)
34899 20 CONTINUE
34900 END
34901
34902*$ CREATE PHO_DZEROX.FOR
34903*COPY PHO_DZEROX
34904CDECK ID>, PHO_DZEROX
34905 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34906C**********************************************************************
34907C
34908C Based on
34909C
34910C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34911C Guaranteed Convergence for Finding a Zero of a Function,
34912C ACM Trans. Math. Software 1 (1975) 330-345.
34913C
34914C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
34915C
34916C CERNLIB C200
34917C
34918C***********************************************************************
34919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34920 SAVE
34921
34922C input/output channels
34923 INTEGER LI,LO
34924 COMMON /POINOU/ LI,LO
34925
34926 CHARACTER NAME*(*)
34927 PARAMETER (NAME = 'PHO_DZEROX')
34928 LOGICAL LMT
34929 DIMENSION IM1(2),IM2(2),LMT(2)
34930 EXTERNAL F
34931
34932 PARAMETER (Z1 = 1, HALF = Z1/2)
34933
34934 DATA IM1 /2,3/, IM2 /-1,3/
34935
34936 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34937 C=-2D+10
34938 WRITE(LO,100) NAME,MODE
34939 GO TO 99
34940 ENDIF
34941 FA=F(B0)
34942 FB=F(A0)
34943 IF(FA*FB .GT. 0) THEN
34944 C=-3D+10
34945 WRITE(LO,101) NAME
34946 GO TO 99
34947 ENDIF
34948 ATL=ABS(EPS)
34949 B=A0
34950 A=B0
34951 LMT(2)=.TRUE.
34952 MF=2
34953 1 C=A
34954 FC=FA
34955 2 IE=0
34956 3 IF(ABS(FC) .LT. ABS(FB)) THEN
34957 IF(C .NE. A) THEN
34958 D=A
34959 FD=FA
34960 END IF
34961 A=B
34962 B=C
34963 C=A
34964 FA=FB
34965 FB=FC
34966 FC=FA
34967 END IF
34968 TOL=ATL*(1+ABS(C))
34969 H=HALF*(C+B)
34970 HB=H-B
34971 IF(ABS(HB) .GT. TOL) THEN
34972 IF(IE .GT. IM1(MODE)) THEN
34973 W=HB
34974 ELSE
34975 TOL=TOL*SIGN(Z1,HB)
34976 P=(B-A)*FB
34977 LMT(1)=IE .LE. 1
34978 IF(LMT(MODE)) THEN
34979 Q=FA-FB
34980 LMT(2)=.FALSE.
34981 ELSE
34982 FDB=(FD-FB)/(D-B)
34983 FDA=(FD-FA)/(D-A)
34984 P=FDA*P
34985 Q=FDB*FA-FDA*FB
34986 END IF
34987 IF(P .LT. 0) THEN
34988 P=-P
34989 Q=-Q
34990 END IF
34991 IF(IE .EQ. IM2(MODE)) P=P+P
34992 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
34993 W=TOL
34994 ELSEIF(P .LT. HB*Q) THEN
34995 W=P/Q
34996 ELSE
34997 W=HB
34998 END IF
34999 END IF
35000 D=A
35001 A=B
35002 FD=FA
35003 FA=FB
35004 B=B+W
35005 MF=MF+1
35006 IF(MF .GT. MAXF) THEN
35007 WRITE(LO,102) NAME
35008 GO TO 99
35009 ENDIF
35010 FB=F(B)
35011 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35012 IF(W .EQ. HB) GO TO 2
35013 IE=IE+1
35014 GO TO 3
35015 END IF
35016 99 CONTINUE
35017 PHO_DZEROX=C
35018 RETURN
35019 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35020 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35021 102 FORMAT(1X,A,': too many function calls')
35022
35023 END
35024
35025*$ CREATE PHO_EXPINT.FOR
35026*COPY PHO_EXPINT
35027CDECK ID>, PHO_EXPINT
35028 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35029C***********************************************************************
35030C
35031C function to calculate E_i(x) = -E_1(-x)
35032C
35033C based on CERNLIB C337 (changed by R.Engel 10/1993)
35034C
35035C***********************************************************************
35036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35037 SAVE
35038
35039C input/output channels
35040 INTEGER LI,LO
35041 COMMON /POINOU/ LI,LO
35042
35043 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35044 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35045 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35046
35047 DATA X0 /0.37250 74107 8137D0/
35048 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35049 DATA P1
35050 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35051 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35052 3 -4.34981 43832 952D+2/
35053 DATA Q1
35054 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35055 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35056 3 +7.53585 64359 843D+2/
35057 DATA P2
35058 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35059 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35060 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35061 4 +4.65627 10797 510D-7/
35062 DATA Q2
35063 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35064 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35065 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35066 4 +1.00000 00000 000D+0/
35067 DATA P3
35068 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35069 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35070 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35071 DATA Q3
35072 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35073 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35074 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35075 DATA P4
35076 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35077 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35078 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35079 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35080 DATA Q4
35081 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35082 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35083 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35084 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35085 DATA A1
35086 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35087 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35088 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35089 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35090 DATA B1
35091 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35092 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35093 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35094 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35095 DATA A2
35096 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35097 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35098 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35099 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35100 DATA B2
35101 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35102 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35103 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35104 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35105 DATA A3
35106 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35107 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35108 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35109 DATA B3
35110 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35111 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35112 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35113C
35114C conversion to E_i function
35115 X = -RXM
35116C
35117 IF(X .LE. XL(1)) THEN
35118 AP=A3(1)-X
35119 DO 1 I = 2,5
35120 1 AP=A3(I)-X+B3(I)/AP
35121 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35122 ELSEIF(X .LE. XL(2)) THEN
35123 AP=A2(1)-X
35124 DO 2 I = 2,7
35125 2 AP=A2(I)-X+B2(I)/AP
35126 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35127 ELSEIF(X .LE. XL(3)) THEN
35128 AP=A1(1)-X
35129 DO 3 I = 2,7
35130 3 AP=A1(I)-X+B1(I)/AP
35131 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35132 ELSEIF(X .LT. XL(4)) THEN
35133 V=-2.D0*(X/3.D0+1.D0)
35134 BP=0.D0
35135 DP=P4(1)
35136 DO 4 I = 2,8
35137 AP=BP
35138 BP=DP
35139 4 DP=P4(I)-AP+V*BP
35140 BQ=0.D0
35141 DQ=Q4(1)
35142 DO 14 I = 2,8
35143 AQ=BQ
35144 BQ=DQ
35145 14 DQ=Q4(I)-AQ+V*BQ
35146 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35147 ELSEIF(X .EQ. XL(4)) THEN
35148* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35149* IF(MFLAG) THEN
35150* IF(LGFILE .EQ. 0) THEN
35151* WRITE(LO,100) ENAME
35152* ELSE
35153* WRITE(LGFILE,100) ENAME
35154* ENDIF
35155* ENDIF
35156* IF(.NOT.RFLAG) CALL ABEND
35157 PHO_EXPINT=0.D0
35158 RETURN
35159 ELSEIF(X .LT. XL(5)) THEN
35160 AP=P1(1)
35161 AQ=Q1(1)
35162 DO 5 I = 2,5
35163 AP=P1(I)+X*AP
35164 5 AQ=Q1(I)+X*AQ
35165 Y=-LOG(X)+AP/AQ
35166 ELSEIF(X .LE. XL(6)) THEN
35167 Y=1.D0/X
35168 AP=P2(1)
35169 AQ=Q2(1)
35170 DO 6 I = 2,7
35171 AP=P2(I)+Y*AP
35172 6 AQ=Q2(I)+Y*AQ
35173 Y=EXP(-X)*AP/AQ
35174 ELSE
35175 Y=1.D0/X
35176 AP=P3(1)
35177 AQ=Q3(1)
35178 DO 7 I = 2,6
35179 AP=P3(I)+Y*AP
35180 7 AQ=Q3(I)+Y*AQ
35181 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35182 ENDIF
35183C sign conversion to E_i
35184 PHO_EXPINT=-Y
35185
35186 END
35187
35188*$ CREATE PHO_RNDBET.FOR
35189*COPY PHO_RNDBET
35190CDECK ID>, PHO_RNDBET
35191 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35192C********************************************************************
35193C
35194C RANDOM NUMBER GENERATION FROM BETA
35195C DISTRIBUTION IN REGION 0 < X < 1.
35196C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35197C *GAMM(ETA))
35198C
35199C********************************************************************
35200 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35201 SAVE
35202
35203 Y = PHO_RNDGAM(1.D0,GAM)
35204 Z = PHO_RNDGAM(1.D0,ETA)
35205
35206 PHO_RNDBET = Y/(Y+Z)
35207
35208 END
35209
35210*$ CREATE PHO_RNDGAM.FOR
35211*COPY PHO_RNDGAM
35212CDECK ID>, PHO_RNDGAM
35213 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35214C********************************************************************
35215C
35216C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35217C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35218C
35219C********************************************************************
35220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35221 SAVE
35222C
35223 NCOU=0
35224 N = ETA
35225 F = ETA - N
35226 IF(F.EQ.0.D0) GOTO 20
35227 10 R = DT_RNDM(ETA)
35228 NCOU=NCOU+1
35229 IF (NCOU.GE.11) GOTO 20
35230 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35231 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35232 IF(ABS(YYY).GT.50.D0) GOTO 20
35233 Y = EXP(YYY)
35234 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35235 GOTO 40
35236 20 Y = 0.D0
35237 GOTO 50
35238 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35239 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35240 40 IF(N.EQ.0) GOTO 70
35241 50 Z = 1.D0
35242 DO 60 I = 1,N
35243 60 Z = Z*DT_RNDM(Y)
35244 Y = Y-LOG(Z+1.0D-9)
35245 70 PHO_RNDGAM = Y/ALAM
35246 RETURN
35247 END
35248
35249*$ CREATE PHO_SFECFE.FOR
35250*COPY PHO_SFECFE
35251CDECK ID>, PHO_SFECFE
35252 SUBROUTINE PHO_SFECFE(SFE,CFE)
35253C**********************************************************************
35254C
35255C fast random SIN(X) COS(X) selection
35256C
35257C**********************************************************************
35258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35259 SAVE
35260C
35261 1 CONTINUE
35262 X=DT_RNDM(XX)
35263 Y=DT_RNDM(YY)
35264 XX=X*X
35265 YY=Y*Y
35266 XY=XX+YY
35267 IF(XY.GT.1.D0) GOTO 1
35268 CFE=(XX-YY)/XY
35269 SFE=2.D0*X*Y/XY
35270 IF(DT_RNDM(XY).LT.0.5D0) THEN
35271 SFE=-SFE
35272 ENDIF
35273 END
35274
35275*$ CREATE PHO_SWAPD.FOR
35276*COPY PHO_SWAPD
35277CDECK ID>, PHO_SWAPD
35278 SUBROUTINE PHO_SWAPD(D1,D2)
35279C********************************************************************
35280C
35281C exchange of argument values (double precision)
35282C
35283C********************************************************************
35284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35285 D = D1
35286 D1 = D2
35287 D2 = D
35288 END
35289
35290*$ CREATE PHO_SWAPI.FOR
35291*COPY PHO_SWAPI
35292CDECK ID>, PHO_SWAPI
35293 SUBROUTINE PHO_SWAPI(I1,I2)
35294C********************************************************************
35295C
35296C exchange of argument values (integer)
35297C
35298C********************************************************************
35299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35300 K = I1
35301 I1 = I2
35302 I2 = K
35303 END
35304
35305*$ CREATE PHO_HADCSL.FOR
35306*COPY PHO_HADCSL
35307CDECK ID>, PHO_HADCSL
35308 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35309 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35310C***********************************************************************
35311C
35312C low-energy cross section parametrizations
35313C
35314C input: ID1,ID2 PDG IDs of particles (meson first)
35315C ECM c.m. energy (GeV)
35316C PLAB lab. momentum (second particle at rest)
35317C IMODE 1 ECM given, PLAB ignored
35318C 2 PLAB given, ECM ignored
35319C
35320C output: SIGTOT total cross section (mb)
35321C SIGEL elastic cross section (mb)
35322C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35323C SLOPE forward elastic slope (GeV**-2)
35324C RHO real/imaginary part of elastic amplitude
35325C
35326C comments:
35327C
35328C - low-energy data interpolation uses PDG fits from 1992 issue
35329C - high-energy extrapolation by Donnachie-Landshoff like fit made
35330C by PDG 1996
35331C - analytic extension of amplitude to calculate rho
35332C
35333C***********************************************************************
35334 IMPLICIT NONE
35335 SAVE
35336
35337 INTEGER ID1,ID2,IMODE
35338 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35339
35340C input/output channels
35341 INTEGER LI,LO
35342 COMMON /POINOU/ LI,LO
35343C some constants
35344 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35345 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35346 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35347C model switches and parameters
35348 CHARACTER*8 MDLNA
35349 INTEGER ISWMDL,IPAMDL
35350 DOUBLE PRECISION PARMDL
35351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35352
35353 INTEGER K
35354 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35355 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35356
35357 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35358
35359 DATA TPDG92 /
35360 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35361 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35362 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35363 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35364 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35365 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35366 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35367 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35368 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35369 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35370 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35371 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35372
35373 DATA TPDG96 /
35374 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35375 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35376 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35377 & 77.15D0,21.05D0,0.46D0,0.9D0,
35378 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35379 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35380 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35381 & 31.85D0,4.05D0,0.45D0,0.9D0,
35382 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35383 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35384 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35385 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35386
35387 DATA BURQ83 /
35388 & 11.13D0, -6.21D0, 0.30D0,
35389 & 11.13D0, 7.23D0, 0.30D0,
35390 & 9.11D0, -0.73D0, 0.28D0,
35391 & 9.11D0, 0.65D0, 0.28D0,
35392 & 8.55D0, -5.98D0, 0.28D0,
35393 & 8.55D0, 1.60D0, 0.28D0 /
35394
35395 DATA XMA /
35396 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35397
35398C find index
35399 IF(ID2.NE.2212) THEN
35400 GOTO 100
35401 ELSE IF(ID1.EQ.2212) THEN
35402 K = 1
35403 ELSE IF(ID1.EQ.-2212) THEN
35404 K = 2
35405 ELSE IF(ID1.EQ.211) THEN
35406 K = 3
35407 ELSE IF(ID1.EQ.-211) THEN
35408 K = 4
35409 ELSE IF(ID1.EQ.321) THEN
35410 K = 5
35411 ELSE IF(ID1.EQ.-321) THEN
35412 K = 6
35413 ELSE
35414 GOTO 100
35415 ENDIF
35416
35417C calculate lab momentum
35418 IF(IMODE.EQ.1) THEN
35419 SS = ECM**2
35420 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35421 PL = SQRT(E1*E1-XMA(K)**2)
35422 ELSE IF(IMODE.EQ.2) THEN
35423 PL = PLAB
35424 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35425 ECM = SQRT(SS)
35426 ELSE
35427 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35428 RETURN
35429 ENDIF
35430 PLL = LOG(PL)
35431
35432C check against lower limit
35433 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35434
35435 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35436 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35437 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35438
35439 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35440 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35441 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35442 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35443
35444C select energy range and interpolation method
35445 IF(PL.LT.TPDG96(1,K)) THEN
35446 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35447 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35448 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35449 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35450 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35451 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35452 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35453 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35454 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35455 SIGTO2 = YP+YM+XP
35456 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35457 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35458 X1 = 1.D0 - X2
35459 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35460 SIGEL = SIGEL2*X2 + SIGEL1*X1
35461 ELSE
35462 SIGTOT = YP+YM+XP
35463 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35464 ENDIF
35465
35466C no parametrization of diffraction implemented
35467 SIGDIF(1) = -1.D0
35468 SIGDIF(2) = -1.D0
35469 SIGDIF(3) = -1.D0
35470
35471 RETURN
35472
35473 100 CONTINUE
35474 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35475 & 'invalid particle combination: ',ID1,ID2
35476 RETURN
35477
35478 200 CONTINUE
35479 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35480 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35481
35482 END
35483
35484*$ CREATE PHO_CSDIFF.FOR
35485*COPY PHO_CSDIFF
35486CDECK ID>, PHO_CSDIFF
35487 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35488 & sig_sd1,sig_sd2,sig_dd)
35489C***********************************************************************
35490C
35491C cross section for diffraction dissociation according to
35492C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35493C
35494C in addition rescaling for different particles is applied using
35495C internal rescaling tables (not implemented yet)
35496C
35497C input: Id1/2 PDG ID's of incoming particles
35498C SS squared c.m. energy (GeV**2)
35499C Xi_min min. diff mass (squared) = Xi_min*SS
35500C Xi_max max. diff mass (squared) = Xi_max*SS
35501C
35502C output: sig_sd1 cross section for diss. of particle 1 (mb)
35503C sig_sd2 cross section for diss. of particle 2 (mb)
35504C sig_dd cross section for diss. of both particles
35505C
35506C***********************************************************************
35507 IMPLICIT NONE
35508 SAVE
35509
35510 INTEGER Id1,Id2
35511 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35512
35513C input/output channels
35514 INTEGER LI,LO
35515 COMMON /POINOU/ LI,LO
35516C some constants
35517 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35518 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35519 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35520
35521 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35522 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35523 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35524 & xms_1,xms_2,CSdiff
35525
35526 INTEGER Ngau1,Ngau2,i1,i2
35527
35528C model parameters
35529
35530 DATA delta / 0.104d0 /
35531 DATA alphap / 0.25d0 /
35532 DATA beta0 / 6.56d0 /
35533 DATA gpom0 / 1.21d0 /
35534 DATA xm_p / 0.938d0 /
35535 DATA x_rad2 / 0.71d0 /
35536
35537C integration precision
35538
35539 DATA Ngau1 / 96 /
35540 DATA Ngau2 / 96 /
35541
35542 sig_sd1 = 0.d0
35543 sig_sd2 = 0.d0
35544 sig_dd = 0.d0
35545
35546 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35547
35548 xm4_p2 = 4.D0*xm_p**2
35549 fac = beta0**2/(16.D0*PI)
35550
35551 t1 = -5.D0
35552 t2 = 0.D0
35553 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35554 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35555
35556C flux renormalization and cross section
35557
35558 Xnorm = 0.d0
35559
35560 xil = log(1.5d0/SS)
35561 xiu = log(0.1d0)
35562
35563 IF(xiu.LE.xil) goto 1000
35564
35565 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35566 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35567
35568 do i1=1,Ngau1
35569
35570 xi = exp(xpos1(i1))
35571 w_xi = Xwgh1(i1)
35572
35573 do i2=1,Ngau2
35574
35575 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35576
35577 alpha_t = 1.D0+delta+alphap*tt
35578 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35579
35580 Xnorm = Xnorm
35581 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35582
35583 enddo
35584 enddo
35585
35586 Xnorm = Xnorm*fac
35587
35588 1000 continue
35589
35590 XIL = LOG(Xi_min)
35591 XIU = LOG(Xi_max)
35592
35593 T1 = -5.D0
35594 T2 = 0.D0
35595
35596 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35597 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35598
35599C single diffraction diss. cross section
35600
35601 CSdiff = 0.d0
35602
35603 IF(XIU.LE.XIL) goto 2000
35604
35605 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35606 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35607
35608 do i1=1,Ngau1
35609
35610 xi = exp(xpos1(i1))
35611 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35612
35613 do i2=1,Ngau2
35614
35615 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35616
35617 alpha_t = 1.D0+delta+alphap*tt
35618 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35619
35620 CSdiff = CSdiff
35621 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35622
35623 enddo
35624 enddo
35625
35626 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35627
35628* WRITE(LO,'(1x,1p,4e14.3)')
35629* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35630
35631 sig_sd1 = CSdiff
35632 sig_sd2 = CSdiff
35633
35634 2000 continue
35635
35636C double diffraction dissociation cross section
35637
35638 CSdiff = 0.d0
35639
35640 xil = log(1.5d0/SS)
35641 xiu = log(Xi_max/1.5d0)
35642
35643 IF(xiu.LE.xil) goto 3000
35644
35645 fac = (beta0*gpom0*SS**delta
35646 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35647 & /(2.d0*alphap)
35648
35649 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35650
35651 do i1=1,Ngau1
35652
35653 xi = exp(xpos1(i1))
35654 xms_1 = xi*SS
35655
35656 xiu = log(Xi_max/(xi*SS))
35657
35658 if(xil.lt.xiu) then
35659
35660 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35661
35662 do i2=1,Ngau2
35663
35664 xms_2 = exp(xpos2(i2))*SS
35665 CSdiff = CSdiff
35666 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35667 & *xwgh1(i1)*xwgh2(i2)
35668
35669 enddo
35670
35671 endif
35672
35673 enddo
35674
35675 sig_dd = CSdiff*fac*GEV2MB
35676
35677 3000 continue
35678
35679 ELSE
35680
35681 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35682 & 'invalid particle combination (Id1/2)',Id1,Id2
35683
35684 ENDIF
35685
35686 END
35687
35688*$ CREATE PHO_ALLM97.FOR
35689*COPY PHO_ALLM97
35690CDECK ID>, PHO_ALLM97
35691 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35692C**********************************************************************
35693C
35694C ALLM97 parametrization for gamma*-p cross section
35695C (for F2 see comments, code adapted from V. Shekelyan, H1)
35696C
35697C**********************************************************************
35698 IMPLICIT NONE
35699 SAVE
35700
35701C input/output channels
35702 INTEGER LI,LO
35703 COMMON /POINOU/ LI,LO
35704
35705 DOUBLE PRECISION Q2,W
35706 DOUBLE PRECISION M02,M12,LAM2,M22
35707 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35708 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35709 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35710 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35711 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35712
35713 W2=W*W
35714 PHO_ALLM97 = 0.D0
35715
35716C pomeron
35717 S11 = 0.28067D0
35718 S12 = 0.22291D0
35719 S13 = 2.1979D0
35720 A11 = -0.0808D0
35721 A12 = -0.44812D0
35722 A13 = 1.1709D0
35723 B11 = 0.60243D0
35724 B12 = 1.3754D0
35725 B13 = 1.8439D0
35726 M12 = 49.457D0
35727
35728C reggeon
35729 S21 = 0.80107D0
35730 S22 = 0.97307D0
35731 S23 = 3.4942D0
35732 A21 = 0.58400D0
35733 A22 = 0.37888D0
35734 A23 = 2.6063D0
35735 B21 = 0.10711D0
35736 B22 = 1.9386D0
35737 B23 = 0.49338D0
35738 M22 = 0.15052D0
35739C
35740 M02 = 0.31985D0
35741 LAM2 = 0.065270D0
35742 Q02 = 0.46017D0 +LAM2
35743
35744C
35745 S=0.
35746 T=LOG((Q2+Q02)/LAM2)
35747 T0=LOG(Q02/LAM2)
35748 IF(Q2.GT.0.D0) S=LOG(T/T0)
35749 Z=1.D0
35750
35751 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35752
35753 IF(S.LT.0.01D0) THEN
35754
35755C pomeron part
35756
35757 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35758
35759 AP=A11
35760 BP=B11**2
35761
35762 SP=S11
35763 F2P=SP*XP**AP*Z**BP
35764
35765C reggeon part
35766
35767 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35768
35769 AR=A21
35770 BR=B21**2
35771
35772 SR=S21
35773 F2R=SR*XR**AR*Z**BR
35774
35775 ELSE
35776
35777C pomeron part
35778
35779 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35780
35781 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35782
35783 BP=B11**2+B12**2*S**B13
35784
35785 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35786
35787 F2P=SP*XP**AP*Z**BP
35788
35789C reggeon part
35790
35791 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35792
35793 AR=A21+A22*S**A23
35794 BR=B21**2+B22**2*S**B23
35795
35796 SR=S21+S22*S**S23
35797 F2R=SR*XR**AR*Z**BR
35798
35799 ENDIF
35800
35801* F2 = (F2P+F2R)*Q2/(Q2+M02)
35802
35803 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35804 PHO_ALLM97 = CIN*(F2P+F2R)
35805
35806 END
35807
35808*$ CREATE PHO_DOR98LO.FOR
35809*COPY PHO_DOR98LO
35810CDECK ID>, PHO_DOR98LO
35811 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35812C***********************************************************************
35813C
35814C GRV98 parton densities, leading order set
35815C
35816C For a detailed explanation see
35817C M. Glueck, E. Reya, A. Vogt :
35818C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35819C (To appear in Eur. Phys. J. C)
35820C
35821C interpolation routine based on the original GRV98PA routine,
35822C adapted to define interpolation table as DATA statements
35823C
35824C (R.Engel, 09/98)
35825C
35826C
35827C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35828C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35829C
35830C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35831C DS = d(bar), SS = s = s(bar), GL = gluon.
35832C Always x times the distribution is returned.
35833C
35834C******************************************************i****************
35835 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35836 SAVE
35837
35838C input/output channels
35839 INTEGER LI,LO
35840 COMMON /POINOU/ LI,LO
35841
35842 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35843 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35844 1 XSF(NX,NQ), XGF(NX,NQ),
35845 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35846
35847 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35848 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35849
35850 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35851 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35852 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35853 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35854 EQUIVALENCE (XSF(1,1),XSF_L(1))
35855 EQUIVALENCE (XGF(1,1),XGF_L(1))
35856
35857 DATA (ARRF(K),K= 1, 95) /
35858 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35859 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35860 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35861 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35862 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35863 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35864 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35865 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35866 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35867 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35868 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35869 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35870 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35871 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35872 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35873 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35874 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35875 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35876 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35877 DATA (XUVF_L(K),K= 1, 114) /
35878 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35879 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35880 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35881 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35882 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35883 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35884 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35885 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35886 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35887 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35888 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35889 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35890 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35891 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35892 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35893 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35894 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35895 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35896 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35897 DATA (XUVF_L(K),K= 115, 228) /
35898 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35899 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35900 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35901 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35902 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35903 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35904 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35905 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35906 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35907 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35908 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35909 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35910 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35911 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35912 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35913 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35914 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35915 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35916 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35917 DATA (XUVF_L(K),K= 229, 342) /
35918 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35919 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35920 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35921 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35922 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35923 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35924 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35925 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35926 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35927 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35928 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35929 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35930 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35931 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35932 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35933 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35934 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35935 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35936 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35937 DATA (XUVF_L(K),K= 343, 456) /
35938 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35939 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35940 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35941 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35942 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35943 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35944 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35945 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35946 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35947 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35948 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35949 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35950 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35951 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35952 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35953 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35954 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35955 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35956 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35957 DATA (XUVF_L(K),K= 457, 570) /
35958 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35959 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35960 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35961 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35962 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35963 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35964 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35965 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35966 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35967 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35968 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35969 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35970 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35971 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35972 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35973 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35974 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35975 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35976 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35977 DATA (XUVF_L(K),K= 571, 684) /
35978 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
35979 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
35980 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
35981 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
35982 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
35983 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
35984 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
35985 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
35986 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
35987 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
35988 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
35989 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
35990 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
35991 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
35992 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
35993 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
35994 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
35995 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
35996 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
35997 DATA (XUVF_L(K),K= 685, 798) /
35998 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
35999 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36000 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36001 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36002 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36003 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36004 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36005 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36006 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36007 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36008 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36009 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36010 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36011 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36012 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36013 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36014 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36015 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36016 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36017 DATA (XUVF_L(K),K= 799, 912) /
36018 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36019 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36020 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36021 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36022 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36023 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36024 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36025 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36026 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36027 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36028 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36029 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36030 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36031 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36032 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36033 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36034 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36035 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36036 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36037 DATA (XUVF_L(K),K= 913, 1026) /
36038 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36039 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36040 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36041 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36042 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36043 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36044 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36045 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36046 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36047 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36048 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36049 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36050 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36051 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36052 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36053 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36054 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36055 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36056 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36057 DATA (XUVF_L(K),K= 1027, 1140) /
36058 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36059 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36060 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36061 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36062 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36063 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36064 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36065 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36066 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36067 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36068 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36069 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36070 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36071 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36072 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36073 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36074 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36075 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36076 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36077 DATA (XUVF_L(K),K= 1141, 1254) /
36078 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36079 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36080 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36081 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36082 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36083 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36084 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36085 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36086 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36087 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36088 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36089 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36090 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36091 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36092 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36093 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36094 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36095 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36096 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36097 DATA (XUVF_L(K),K= 1255, 1368) /
36098 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36099 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36100 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36101 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36102 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36103 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36104 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36105 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36106 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36107 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36108 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36109 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36110 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36111 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36112 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36113 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36114 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36115 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36116 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36117 DATA (XUVF_L(K),K= 1369, 1482) /
36118 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36119 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36120 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36121 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36122 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36123 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36124 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36125 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36126 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36127 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36128 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36129 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36130 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36131 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36132 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36133 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36134 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36135 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36136 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36137 DATA (XUVF_L(K),K= 1483, 1596) /
36138 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36139 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36140 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36141 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36142 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36143 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36144 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36145 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36146 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36147 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36148 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36149 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36150 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36151 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36152 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36153 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36154 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36155 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36156 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36157 DATA (XUVF_L(K),K= 1597, 1710) /
36158 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36159 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36160 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36161 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36162 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36163 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36164 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36165 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36166 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36167 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36168 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36169 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36170 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36171 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36172 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36173 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36174 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36175 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36176 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36177 DATA (XUVF_L(K),K= 1711, 1824) /
36178 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36179 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36180 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36181 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36182 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36183 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36184 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36185 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36186 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36187 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36188 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36189 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36190 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36191 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36192 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36193 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36194 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36195 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36196 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36197 DATA (XUVF_L(K),K= 1825, 1836) /
36198 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36199 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36200 DATA (XDVF_L(K),K= 1, 114) /
36201 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36202 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36203 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36204 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36205 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36206 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36207 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36208 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36209 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36210 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36211 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36212 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36213 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36214 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36215 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36216 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36217 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36218 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36219 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36220 DATA (XDVF_L(K),K= 115, 228) /
36221 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36222 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36223 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36224 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36225 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36226 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36227 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36228 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36229 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36230 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36231 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36232 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36233 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36234 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36235 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36236 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36237 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36238 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36239 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36240 DATA (XDVF_L(K),K= 229, 342) /
36241 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36242 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36243 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36244 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36245 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36246 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36247 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36248 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36249 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36250 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36251 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36252 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36253 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36254 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36255 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36256 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36257 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36258 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36259 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36260 DATA (XDVF_L(K),K= 343, 456) /
36261 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36262 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36263 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36264 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36265 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36266 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36267 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36268 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36269 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36270 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36271 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36272 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36273 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36274 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36275 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36276 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36277 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36278 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36279 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36280 DATA (XDVF_L(K),K= 457, 570) /
36281 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36282 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36283 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36284 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36285 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36286 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36287 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36288 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36289 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36290 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36291 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36292 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36293 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36294 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36295 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36296 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36297 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36298 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36299 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36300 DATA (XDVF_L(K),K= 571, 684) /
36301 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36302 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36303 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36304 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36305 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36306 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36307 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36308 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36309 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36310 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36311 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36312 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36313 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36314 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36315 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36316 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36317 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36318 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36319 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36320 DATA (XDVF_L(K),K= 685, 798) /
36321 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36322 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36323 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36324 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36325 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36326 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36327 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36328 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36329 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36330 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36331 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36332 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36333 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36334 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36335 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36336 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36337 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36338 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36339 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36340 DATA (XDVF_L(K),K= 799, 912) /
36341 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36342 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36343 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36344 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36345 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36346 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36347 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36348 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36349 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36350 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36351 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36352 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36353 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36354 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36355 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36356 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36357 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36358 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36359 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36360 DATA (XDVF_L(K),K= 913, 1026) /
36361 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36362 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36363 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36364 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36365 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36366 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36367 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36368 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36369 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36370 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36371 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36372 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36373 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36374 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36375 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36376 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36377 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36378 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36379 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36380 DATA (XDVF_L(K),K= 1027, 1140) /
36381 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36382 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36383 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36384 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36385 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36386 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36387 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36388 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36389 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36390 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36391 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36392 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36393 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36394 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36395 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36396 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36397 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36398 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36399 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36400 DATA (XDVF_L(K),K= 1141, 1254) /
36401 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36402 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36403 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36404 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36405 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36406 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36407 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36408 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36409 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36410 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36411 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36412 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36413 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36414 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36415 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36416 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36417 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36418 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36419 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36420 DATA (XDVF_L(K),K= 1255, 1368) /
36421 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36422 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36423 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36424 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36425 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36426 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36427 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36428 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36429 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36430 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36431 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36432 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36433 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36434 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36435 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36436 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36437 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36438 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36439 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36440 DATA (XDVF_L(K),K= 1369, 1482) /
36441 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36442 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36443 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36444 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36445 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36446 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36447 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36448 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36449 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36450 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36451 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36452 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36453 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36454 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36455 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36456 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36457 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36458 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36459 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36460 DATA (XDVF_L(K),K= 1483, 1596) /
36461 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36462 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36463 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36464 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36465 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36466 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36467 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36468 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36469 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36470 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36471 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36472 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36473 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36474 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36475 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36476 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36477 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36478 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36479 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36480 DATA (XDVF_L(K),K= 1597, 1710) /
36481 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36482 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36483 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36484 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36485 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36486 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36487 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36488 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36489 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36490 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36491 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36492 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36493 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36494 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36495 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36496 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36497 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36498 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36499 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36500 DATA (XDVF_L(K),K= 1711, 1824) /
36501 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36502 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36503 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36504 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36505 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36506 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36507 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36508 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36509 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36510 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36511 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36512 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36513 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36514 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36515 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36516 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36517 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36518 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36519 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36520 DATA (XDVF_L(K),K= 1825, 1836) /
36521 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36522 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36523 DATA (XDEF_L(K),K= 1, 114) /
36524 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36525 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36526 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36527 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36528 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36529 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36530 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36531 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36532 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36533 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36534 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36535 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36536 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36537 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36538 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36539 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36540 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36541 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36542 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36543 DATA (XDEF_L(K),K= 115, 228) /
36544 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36545 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36546 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36547 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36548 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36549 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36550 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36551 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36552 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36553 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36554 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36555 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36556 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36557 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36558 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36559 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36560 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36561 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36562 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36563 DATA (XDEF_L(K),K= 229, 342) /
36564 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36565 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36566 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36567 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36568 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36569 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36570 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36571 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36572 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36573 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36574 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36575 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36576 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36577 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36578 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36579 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36580 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36581 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36582 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36583 DATA (XDEF_L(K),K= 343, 456) /
36584 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36585 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36586 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36587 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36588 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36589 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36590 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36591 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36592 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36593 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36594 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36595 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36596 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36597 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36598 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36599 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36600 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36601 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36602 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36603 DATA (XDEF_L(K),K= 457, 570) /
36604 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36605 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36606 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36607 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36608 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36609 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36610 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36611 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36612 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36613 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36614 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36615 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36616 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36617 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36618 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36619 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36620 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36621 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36622 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36623 DATA (XDEF_L(K),K= 571, 684) /
36624 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36625 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36626 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36627 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36628 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36629 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36630 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36631 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36632 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36633 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36634 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36635 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36636 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36637 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36638 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36639 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36640 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36641 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36642 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36643 DATA (XDEF_L(K),K= 685, 798) /
36644 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36645 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36646 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36647 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36648 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36649 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36650 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36651 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36652 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36653 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36654 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36655 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36656 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36657 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36658 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36659 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36660 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36661 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36662 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36663 DATA (XDEF_L(K),K= 799, 912) /
36664 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36665 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36666 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36667 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36668 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36669 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36670 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36671 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36672 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36673 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36674 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36675 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36676 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36677 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36678 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36679 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36680 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36681 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36682 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36683 DATA (XDEF_L(K),K= 913, 1026) /
36684 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36685 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36686 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36687 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36688 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36689 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36690 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36691 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36692 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36693 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36694 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36695 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36696 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36697 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36698 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36699 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36700 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36701 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36702 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36703 DATA (XDEF_L(K),K= 1027, 1140) /
36704 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36705 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36706 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36707 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36708 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36709 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36710 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36711 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36712 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36713 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36714 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36715 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36716 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36717 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36718 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36719 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36720 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36721 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36722 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36723 DATA (XDEF_L(K),K= 1141, 1254) /
36724 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36725 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36726 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36727 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36728 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36729 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36730 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36731 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36732 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36733 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36734 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36735 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36736 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36737 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36738 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36739 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36740 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36741 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36742 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36743 DATA (XDEF_L(K),K= 1255, 1368) /
36744 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36745 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36746 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36747 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36748 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36749 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36750 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36751 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36752 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36753 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36754 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36755 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36756 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36757 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36758 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36759 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36760 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36761 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36762 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36763 DATA (XDEF_L(K),K= 1369, 1482) /
36764 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36765 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36766 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36767 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36768 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36769 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36770 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36771 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36772 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36773 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36774 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36775 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36776 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36777 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36778 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36779 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36780 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36781 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36782 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36783 DATA (XDEF_L(K),K= 1483, 1596) /
36784 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36785 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36786 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36787 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36788 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36789 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36790 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36791 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36792 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36793 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36794 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36795 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36796 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36797 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36798 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36799 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36800 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36801 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36802 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36803 DATA (XDEF_L(K),K= 1597, 1710) /
36804 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36805 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36806 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36807 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36808 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36809 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36810 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36811 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36812 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36813 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36814 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36815 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36816 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36817 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36818 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36819 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36820 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36821 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36822 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36823 DATA (XDEF_L(K),K= 1711, 1824) /
36824 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36825 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36826 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36827 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36828 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36829 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36830 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36831 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36832 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36833 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36834 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36835 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36836 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36837 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36838 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36839 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36840 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36841 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36842 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36843 DATA (XDEF_L(K),K= 1825, 1836) /
36844 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36845 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36846 DATA (XUDF_L(K),K= 1, 114) /
36847 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36848 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36849 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36850 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36851 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36852 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36853 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36854 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36855 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36856 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36857 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36858 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36859 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36860 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36861 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36862 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36863 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36864 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36865 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36866 DATA (XUDF_L(K),K= 115, 228) /
36867 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36868 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36869 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36870 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36871 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36872 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36873 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36874 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36875 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36876 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36877 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36878 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36879 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36880 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36881 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36882 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36883 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36884 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36885 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36886 DATA (XUDF_L(K),K= 229, 342) /
36887 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36888 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36889 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36890 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36891 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36892 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36893 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36894 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36895 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36896 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36897 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36898 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36899 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36900 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36901 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36902 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36903 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36904 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36905 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36906 DATA (XUDF_L(K),K= 343, 456) /
36907 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36908 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36909 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36910 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36911 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36912 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36913 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36914 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36915 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36916 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36917 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36918 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36919 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36920 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36921 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36922 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36923 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36924 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36925 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36926 DATA (XUDF_L(K),K= 457, 570) /
36927 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36928 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36929 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36930 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36931 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36932 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36933 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36934 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36935 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36936 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36937 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36938 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36939 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36940 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36941 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36942 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36943 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36944 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36945 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36946 DATA (XUDF_L(K),K= 571, 684) /
36947 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36948 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36949 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36950 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36951 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36952 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36953 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36954 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36955 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36956 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36957 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36958 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36959 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36960 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36961 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36962 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36963 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36964 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36965 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36966 DATA (XUDF_L(K),K= 685, 798) /
36967 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36968 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36969 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36970 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36971 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36972 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36973 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36974 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36975 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36976 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36977 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
36978 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
36979 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
36980 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
36981 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
36982 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
36983 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
36984 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
36985 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
36986 DATA (XUDF_L(K),K= 799, 912) /
36987 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
36988 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
36989 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
36990 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
36991 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
36992 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
36993 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
36994 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
36995 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
36996 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
36997 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
36998 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
36999 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37000 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37001 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37002 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37003 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37004 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37005 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37006 DATA (XUDF_L(K),K= 913, 1026) /
37007 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37008 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37009 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37010 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37011 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37012 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37013 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37014 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37015 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37016 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37017 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37018 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37019 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37020 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37021 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37022 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37023 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37024 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37025 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37026 DATA (XUDF_L(K),K= 1027, 1140) /
37027 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37028 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37029 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37030 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37031 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37032 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37033 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37034 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37035 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37036 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37037 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37038 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37039 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37040 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37041 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37042 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37043 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37044 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37045 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37046 DATA (XUDF_L(K),K= 1141, 1254) /
37047 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37048 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37049 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37050 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37051 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37052 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37053 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37054 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37055 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37056 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37057 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37058 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37059 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37060 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37061 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37062 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37063 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37064 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37065 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37066 DATA (XUDF_L(K),K= 1255, 1368) /
37067 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37068 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37069 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37070 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37071 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37072 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37073 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37074 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37075 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37076 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37077 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37078 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37079 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37080 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37081 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37082 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37083 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37084 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37085 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37086 DATA (XUDF_L(K),K= 1369, 1482) /
37087 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37088 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37089 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37090 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37091 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37092 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37093 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37094 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37095 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37096 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37097 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37098 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37099 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37100 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37101 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37102 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37103 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37104 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37105 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37106 DATA (XUDF_L(K),K= 1483, 1596) /
37107 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37108 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37109 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37110 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37111 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37112 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37113 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37114 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37115 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37116 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37117 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37118 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37119 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37120 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37121 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37122 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37123 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37124 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37125 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37126 DATA (XUDF_L(K),K= 1597, 1710) /
37127 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37128 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37129 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37130 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37131 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37132 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37133 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37134 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37135 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37136 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37137 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37138 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37139 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37140 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37141 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37142 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37143 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37144 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37145 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37146 DATA (XUDF_L(K),K= 1711, 1824) /
37147 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37148 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37149 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37150 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37151 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37152 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37153 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37154 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37155 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37156 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37157 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37158 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37159 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37160 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37161 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37162 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37163 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37164 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37165 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37166 DATA (XUDF_L(K),K= 1825, 1836) /
37167 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37168 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37169 DATA (XSF_L(K),K= 1, 114) /
37170 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37171 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37172 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37173 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37174 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37175 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37176 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37177 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37178 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37179 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37180 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37181 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37182 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37183 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37184 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37185 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37186 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37187 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37188 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37189 DATA (XSF_L(K),K= 115, 228) /
37190 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37191 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37192 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37193 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37194 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37195 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37196 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37197 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37198 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37199 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37200 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37201 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37202 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37203 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37204 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37205 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37206 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37207 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37208 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37209 DATA (XSF_L(K),K= 229, 342) /
37210 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37211 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37212 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37213 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37214 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37215 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37216 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37217 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37218 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37219 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37220 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37221 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37222 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37223 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37224 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37225 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37226 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37227 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37228 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37229 DATA (XSF_L(K),K= 343, 456) /
37230 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37231 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37232 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37233 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37234 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37235 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37236 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37237 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37238 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37239 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37240 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37241 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37242 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37243 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37244 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37245 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37246 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37247 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37248 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37249 DATA (XSF_L(K),K= 457, 570) /
37250 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37251 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37252 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37253 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37254 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37255 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37256 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37257 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37258 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37259 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37260 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37261 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37262 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37263 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37264 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37265 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37266 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37267 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37268 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37269 DATA (XSF_L(K),K= 571, 684) /
37270 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37271 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37272 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37273 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37274 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37275 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37276 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37277 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37278 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37279 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37280 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37281 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37282 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37283 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37284 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37285 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37286 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37287 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37288 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37289 DATA (XSF_L(K),K= 685, 798) /
37290 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37291 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37292 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37293 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37294 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37295 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37296 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37297 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37298 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37299 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37300 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37301 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37302 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37303 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37304 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37305 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37306 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37307 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37308 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37309 DATA (XSF_L(K),K= 799, 912) /
37310 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37311 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37312 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37313 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37314 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37315 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37316 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37317 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37318 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37319 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37320 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37321 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37322 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37323 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37324 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37325 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37326 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37327 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37328 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37329 DATA (XSF_L(K),K= 913, 1026) /
37330 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37331 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37332 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37333 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37334 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37335 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37336 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37337 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37338 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37339 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37340 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37341 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37342 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37343 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37344 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37345 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37346 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37347 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37348 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37349 DATA (XSF_L(K),K= 1027, 1140) /
37350 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37351 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37352 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37353 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37354 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37355 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37356 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37357 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37358 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37359 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37360 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37361 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37362 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37363 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37364 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37365 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37366 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37367 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37368 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37369 DATA (XSF_L(K),K= 1141, 1254) /
37370 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37371 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37372 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37373 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37374 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37375 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37376 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37377 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37378 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37379 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37380 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37381 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37382 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37383 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37384 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37385 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37386 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37387 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37388 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37389 DATA (XSF_L(K),K= 1255, 1368) /
37390 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37391 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37392 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37393 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37394 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37395 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37396 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37397 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37398 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37399 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37400 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37401 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37402 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37403 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37404 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37405 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37406 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37407 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37408 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37409 DATA (XSF_L(K),K= 1369, 1482) /
37410 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37411 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37412 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37413 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37414 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37415 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37416 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37417 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37418 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37419 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37420 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37421 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37422 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37423 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37424 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37425 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37426 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37427 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37428 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37429 DATA (XSF_L(K),K= 1483, 1596) /
37430 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37431 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37432 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37433 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37434 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37435 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37436 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37437 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37438 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37439 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37440 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37441 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37442 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37443 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37444 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37445 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37446 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37447 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37448 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37449 DATA (XSF_L(K),K= 1597, 1710) /
37450 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37451 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37452 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37453 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37454 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37455 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37456 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37457 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37458 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37459 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37460 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37461 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37462 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37463 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37464 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37465 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37466 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37467 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37468 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37469 DATA (XSF_L(K),K= 1711, 1824) /
37470 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37471 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37472 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37473 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37474 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37475 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37476 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37477 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37478 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37479 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37480 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37481 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37482 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37483 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37484 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37485 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37486 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37487 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37488 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37489 DATA (XSF_L(K),K= 1825, 1836) /
37490 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37491 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37492 DATA (XGF_L(K),K= 1, 114) /
37493 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37494 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37495 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37496 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37497 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37498 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37499 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37500 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37501 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37502 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37503 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37504 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37505 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37506 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37507 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37508 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37509 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37510 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37511 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37512 DATA (XGF_L(K),K= 115, 228) /
37513 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37514 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37515 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37516 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37517 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37518 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37519 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37520 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37521 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37522 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37523 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37524 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37525 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37526 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37527 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37528 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37529 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37530 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37531 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37532 DATA (XGF_L(K),K= 229, 342) /
37533 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37534 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37535 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37536 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37537 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37538 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37539 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37540 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37541 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37542 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37543 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37544 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37545 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37546 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37547 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37548 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37549 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37550 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37551 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37552 DATA (XGF_L(K),K= 343, 456) /
37553 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37554 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37555 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37556 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37557 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37558 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37559 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37560 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37561 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37562 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37563 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37564 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37565 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37566 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37567 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37568 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37569 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37570 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37571 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37572 DATA (XGF_L(K),K= 457, 570) /
37573 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37574 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37575 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37576 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37577 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37578 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37579 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37580 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37581 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37582 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37583 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37584 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37585 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37586 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37587 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37588 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37589 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37590 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37591 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37592 DATA (XGF_L(K),K= 571, 684) /
37593 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37594 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37595 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37596 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37597 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37598 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37599 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37600 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37601 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37602 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37603 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37604 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37605 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37606 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37607 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37608 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37609 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37610 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37611 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37612 DATA (XGF_L(K),K= 685, 798) /
37613 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37614 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37615 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37616 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37617 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37618 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37619 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37620 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37621 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37622 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37623 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37624 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37625 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37626 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37627 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37628 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37629 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37630 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37631 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37632 DATA (XGF_L(K),K= 799, 912) /
37633 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37634 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37635 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37636 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37637 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37638 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37639 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37640 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37641 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37642 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37643 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37644 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37645 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37646 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37647 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37648 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37649 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37650 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37651 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37652 DATA (XGF_L(K),K= 913, 1026) /
37653 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37654 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37655 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37656 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37657 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37658 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37659 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37660 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37661 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37662 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37663 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37664 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37665 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37666 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37667 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37668 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37669 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37670 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37671 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37672 DATA (XGF_L(K),K= 1027, 1140) /
37673 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37674 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37675 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37676 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37677 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37678 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37679 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37680 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37681 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37682 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37683 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37684 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37685 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37686 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37687 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37688 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37689 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37690 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37691 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37692 DATA (XGF_L(K),K= 1141, 1254) /
37693 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37694 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37695 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37696 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37697 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37698 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37699 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37700 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37701 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37702 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37703 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37704 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37705 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37706 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37707 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37708 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37709 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37710 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37711 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37712 DATA (XGF_L(K),K= 1255, 1368) /
37713 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37714 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37715 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37716 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37717 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37718 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37719 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37720 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37721 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37722 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37723 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37724 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37725 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37726 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37727 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37728 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37729 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37730 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37731 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37732 DATA (XGF_L(K),K= 1369, 1482) /
37733 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37734 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37735 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37736 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37737 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37738 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37739 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37740 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37741 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37742 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37743 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37744 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37745 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37746 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37747 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37748 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37749 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37750 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37751 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37752 DATA (XGF_L(K),K= 1483, 1596) /
37753 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37754 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37755 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37756 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37757 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37758 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37759 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37760 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37761 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37762 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37763 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37764 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37765 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37766 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37767 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37768 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37769 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37770 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37771 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37772 DATA (XGF_L(K),K= 1597, 1710) /
37773 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37774 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37775 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37776 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37777 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37778 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37779 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37780 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37781 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37782 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37783 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37784 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37785 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37786 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37787 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37788 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37789 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37790 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37791 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37792 DATA (XGF_L(K),K= 1711, 1824) /
37793 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37794 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37795 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37796 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37797 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37798 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37799 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37800 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37801 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37802 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37803 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37804 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37805 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37806 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37807 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37808 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37809 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37810 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37811 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37812 DATA (XGF_L(K),K= 1825, 1836) /
37813 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37814 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37815
37816*
37817 X = Xinp
37818*...CHECK OF X AND Q2 VALUES :
37819 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37820* WRITE(LO,91) X
37821 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37822 X = 0.99D-9
37823* STOP
37824 ENDIF
37825
37826 Q2 = Q2inp
37827 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37828* WRITE(LO,92) Q2
37829 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37830 Q2 = 0.99E6
37831* STOP
37832 ENDIF
37833
37834*
37835*...INTERPOLATION :
37836 NA(1) = NX
37837 NA(2) = NQ
37838 XT(1) = DLOG(X)
37839 XT(2) = DLOG(Q2)
37840 X1 = 1.- X
37841 XV = X**0.5
37842 XS = X**(-0.2)
37843 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37844 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37845 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37846 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37847 US = 0.5 * (UD - DE)
37848 DS = 0.5 * (UD + DE)
37849 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37850 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37851
37852 END
37853
37854*$ CREATE PHO_DOR98SC.FOR
37855*COPY PHO_DOR98SC
37856CDECK ID>, PHO_DOR98SC
37857 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37858C***********************************************************************
37859C
37860C GRV98 parton densities, leading order set
37861C
37862C For a detailed explanation see
37863C M. Glueck, E. Reya, A. Vogt :
37864C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37865C (To appear in Eur. Phys. J. C)
37866C
37867C interpolation routine based on the original GRV98PA routine,
37868C adapted to define interpolation table as DATA statements
37869C
37870C (R.Engel, 09/98)
37871C
37872C CAUTION: this is a version with gluon shadowing corrections
37873C (R.Engel, 09/99)
37874C
37875C
37876C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37877C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37878C
37879C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37880C DS = d(bar), SS = s = s(bar), GL = gluon.
37881C Always x times the distribution is returned.
37882C
37883C******************************************************i****************
37884 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37885 SAVE
37886
37887C input/output channels
37888 INTEGER LI,LO
37889 COMMON /POINOU/ LI,LO
37890
37891 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37892 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37893 1 XSF(NX,NQ), XGF(NX,NQ),
37894 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
37895
37896 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37897 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37898
37899 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37900 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37901 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37902 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37903 EQUIVALENCE (XSF(1,1),XSF_L(1))
37904 EQUIVALENCE (XGF(1,1),XGF_L(1))
37905
37906*#################### data statements for shadowed LO PDF ##############
37907C ... deleted ...
37908*#######################################################################
37909
37910 X = Xinp
37911*...CHECK OF X AND Q2 VALUES :
37912 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37913* WRITE(LO,91) X
37914 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37915 X = 0.99D-9
37916* STOP
37917 ENDIF
37918
37919 Q2 = Q2inp
37920 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37921* WRITE(LO,92) Q2
37922 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37923 Q2 = 0.99E6
37924* STOP
37925 ENDIF
37926
37927*
37928*...INTERPOLATION :
37929 NA(1) = NX
37930 NA(2) = NQ
37931 XT(1) = DLOG(X)
37932 XT(2) = DLOG(Q2)
37933 X1 = 1.- X
37934 XV = X**0.5
37935 XS = X**(-0.2)
37936 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37937 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37938 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37939 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37940 US = 0.5 * (UD - DE)
37941 DS = 0.5 * (UD + DE)
37942 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37943 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37944
37945 END
37946
37947*$ CREATE PHO_DOR94LO.FOR
37948*COPY PHO_DOR94LO
37949CDECK ID>, PHO_DOR94LO
37950* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37951* *
37952* 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 *
37953* *
37954* 1994 UPDATE *
37955* *
37956* FOR A DETAILED EXPLANATION SEE *
37957* M. GLUECK, E.REYA, A.VOGT : *
37958* DO-TH 94/24 = DESY 94-206 *
37959* (TO APPEAR IN Z. PHYS. C) *
37960* *
37961* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
37962* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
37963* X BETWEEN 1.E-5 AND 1. *
37964* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
37965* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
37966* *
37967* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
37968* M(C) = 1.5, M(B) = 4.5 *
37969* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
37970* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
37971* LAMBDA(5) = 0.153, *
37972* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
37973* LAMBDA(5) = 0.131. *
37974* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
37975* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
37976* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
37977* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
37978* GRV PARAMETRIZATION. *
37979* *
37980* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
37981* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
37982* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
37983* *
37984* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37985*
37986*...INPUT PARAMETERS :
37987*
37988* X = MOMENTUM FRACTION
37989* Q2 = SCALE Q**2 IN GEV**2
37990*
37991*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
37992*
37993* UV = U(VAL) = U - U(BAR)
37994* DV = D(VAL) = D - D(BAR)
37995* DEL = D(BAR) - U(BAR)
37996* UDB = U(BAR) + D(BAR)
37997* SB = S = S(BAR)
37998* GL = GLUON
37999*
38000*...LO PARAMETRIZATION :
38001*
38002 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38003 IMPLICIT DOUBLE PRECISION (A - Z)
38004 SAVE
38005
38006 MU2 = 0.23
38007 LAM2 = 0.2322 * 0.2322
38008 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38009 DS = SQRT (S)
38010 S2 = S * S
38011 S3 = S2 * S
38012*...UV :
38013 NU = 2.284 + 0.802 * S + 0.055 * S2
38014 AKU = 0.590 - 0.024 * S
38015 BKU = 0.131 + 0.063 * S
38016 AU = -0.449 - 0.138 * S - 0.076 * S2
38017 BU = 0.213 + 2.669 * S - 0.728 * S2
38018 CU = 8.854 - 9.135 * S + 1.979 * S2
38019 DU = 2.997 + 0.753 * S - 0.076 * S2
38020 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38021*...DV :
38022 ND = 0.371 + 0.083 * S + 0.039 * S2
38023 AKD = 0.376
38024 BKD = 0.486 + 0.062 * S
38025 AD = -0.509 + 3.310 * S - 1.248 * S2
38026 BD = 12.41 - 10.52 * S + 2.267 * S2
38027 CD = 6.373 - 6.208 * S + 1.418 * S2
38028 DD = 3.691 + 0.799 * S - 0.071 * S2
38029 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38030*...DEL :
38031 NE = 0.082 + 0.014 * S + 0.008 * S2
38032 AKE = 0.409 - 0.005 * S
38033 BKE = 0.799 + 0.071 * S
38034 AE = -38.07 + 36.13 * S - 0.656 * S2
38035 BE = 90.31 - 74.15 * S + 7.645 * S2
38036 CE = 0.0
38037 DE = 7.486 + 1.217 * S - 0.159 * S2
38038 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38039*...UDB :
38040 ALX = 1.451
38041 BEX = 0.271
38042 AKX = 0.410 - 0.232 * S
38043 BKX = 0.534 - 0.457 * S
38044 AGX = 0.890 - 0.140 * S
38045 BGX = -0.981
38046 CX = 0.320 + 0.683 * S
38047 DX = 4.752 + 1.164 * S + 0.286 * S2
38048 EX = 4.119 + 1.713 * S
38049 ESX = 0.682 + 2.978 * S
38050 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38051*...SB :
38052 ALS = 0.914
38053 BES = 0.577
38054 AKS = 1.798 - 0.596 * S
38055 AS = -5.548 + 3.669 * DS - 0.616 * S
38056 BS = 18.92 - 16.73 * DS + 5.168 * S
38057 DST = 6.379 - 0.350 * S + 0.142 * S2
38058 EST = 3.981 + 1.638 * S
38059 ESS = 6.402
38060 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38061*...GL :
38062 ALG = 0.524
38063 BEG = 1.088
38064 AKG = 1.742 - 0.930 * S
38065 BKG = - 0.399 * S2
38066 AG = 7.486 - 2.185 * S
38067 BG = 16.69 - 22.74 * S + 5.779 * S2
38068 CG = -25.59 + 29.71 * S - 7.296 * S2
38069 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38070 EG = 0.807 + 2.005 * S
38071 ESG = 3.841 + 0.316 * S
38072 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38073
38074 END
38075
38076*
38077*...NLO PARAMETRIZATION (MS(BAR)) :
38078*
38079*$ CREATE PHO_DOR94HO.FOR
38080*COPY PHO_DOR94HO
38081CDECK ID>, PHO_DOR94HO
38082 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38083 IMPLICIT DOUBLE PRECISION (A - Z)
38084 SAVE
38085
38086 MU2 = 0.34
38087 LAM2 = 0.248 * 0.248
38088 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38089 DS = SQRT (S)
38090 S2 = S * S
38091 S3 = S2 * S
38092*...UV :
38093 NU = 1.304 + 0.863 * S
38094 AKU = 0.558 - 0.020 * S
38095 BKU = 0.183 * S
38096 AU = -0.113 + 0.283 * S - 0.321 * S2
38097 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38098 CU = 7.771 - 10.09 * S + 2.630 * S2
38099 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38100 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38101*...DV :
38102 ND = 0.102 - 0.017 * S + 0.005 * S2
38103 AKD = 0.270 - 0.019 * S
38104 BKD = 0.260
38105 AD = 2.393 + 6.228 * S - 0.881 * S2
38106 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38107 CD = 17.83 - 53.47 * S + 21.24 * S2
38108 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38109 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38110*...DEL :
38111 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38112 AKE = 0.409 - 0.007 * S
38113 BKE = 0.782 + 0.082 * S
38114 AE = -29.65 + 26.49 * S + 5.429 * S2
38115 BE = 90.20 - 74.97 * S + 4.526 * S2
38116 CE = 0.0
38117 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38118 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38119*...UDB :
38120 ALX = 0.877
38121 BEX = 0.561
38122 AKX = 0.275
38123 BKX = 0.0
38124 AGX = 0.997
38125 BGX = 3.210 - 1.866 * S
38126 CX = 7.300
38127 DX = 9.010 + 0.896 * DS + 0.222 * S2
38128 EX = 3.077 + 1.446 * S
38129 ESX = 3.173 - 2.445 * DS + 2.207 * S
38130 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38131*...SB :
38132 ALS = 0.756
38133 BES = 0.216
38134 AKS = 1.690 + 0.650 * DS - 0.922 * S
38135 AS = -4.329 + 1.131 * S
38136 BS = 9.568 - 1.744 * S
38137 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38138 EST = 3.031 + 1.639 * S
38139 ESS = 5.837 + 0.815 * S
38140 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38141*...GL :
38142 ALG = 1.014
38143 BEG = 1.738
38144 AKG = 1.724 + 0.157 * S
38145 BKG = 0.800 + 1.016 * S
38146 AG = 7.517 - 2.547 * S
38147 BG = 34.09 - 52.21 * DS + 17.47 * S
38148 CG = 4.039 + 1.491 * S
38149 DG = 3.404 + 0.830 * S
38150 EG = -1.112 + 3.438 * S - 0.302 * S2
38151 ESG = 3.256 - 0.436 * S
38152 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38153
38154 END
38155
38156*$ CREATE PHO_DOR94DI.FOR
38157*COPY PHO_DOR94DI
38158CDECK ID>, PHO_DOR94DI
38159*
38160*...NLO PARAMETRIZATION (DIS) :
38161*
38162 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38163 IMPLICIT DOUBLE PRECISION (A - Z)
38164 SAVE
38165
38166 MU2 = 0.34
38167 LAM2 = 0.248 * 0.248
38168 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38169 DS = SQRT (S)
38170 S2 = S * S
38171 S3 = S2 * S
38172*...UV :
38173 NU = 2.484 + 0.116 * S + 0.093 * S2
38174 AKU = 0.563 - 0.025 * S
38175 BKU = 0.054 + 0.154 * S
38176 AU = -0.326 - 0.058 * S - 0.135 * S2
38177 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38178 CU = 11.52 - 12.99 * S + 3.161 * S2
38179 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38180 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38181*...DV :
38182 ND = 0.156 - 0.017 * S
38183 AKD = 0.299 - 0.022 * S
38184 BKD = 0.259 - 0.015 * S
38185 AD = 3.445 + 1.278 * S + 0.326 * S2
38186 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38187 CD = 55.45 - 69.92 * S + 20.78 * S2
38188 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38189 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38190*...DEL :
38191 NE = 0.099 + 0.019 * S + 0.002 * S2
38192 AKE = 0.419 - 0.013 * S
38193 BKE = 1.064 - 0.038 * S
38194 AE = -44.00 + 98.70 * S - 14.79 * S2
38195 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38196 CE = 84.57 - 108.8 * S + 31.52 * S2
38197 DE = 7.469 + 2.480 * S - 0.866 * S2
38198 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38199*...UDB :
38200 ALX = 1.215
38201 BEX = 0.466
38202 AKX = 0.326 + 0.150 * S
38203 BKX = 0.956 + 0.405 * S
38204 AGX = 0.272
38205 BGX = 3.794 - 2.359 * DS
38206 CX = 2.014
38207 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38208 EX = 3.049 + 1.597 * S
38209 ESX = 4.396 - 4.594 * DS + 3.268 * S
38210 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38211*...SB :
38212 ALS = 0.175
38213 BES = 0.344
38214 AKS = 1.415 - 0.641 * DS
38215 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38216 BS = 5.617 + 5.709 * DS - 3.972 * S
38217 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38218 EST = 4.546 + 0.372 * S2
38219 ESS = 5.053 - 1.070 * S + 0.805 * S2
38220 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38221*...GL :
38222 ALG = 1.258
38223 BEG = 1.846
38224 AKG = 2.423
38225 BKG = 2.427 + 1.311 * S - 0.153 * S2
38226 AG = 25.09 - 7.935 * S
38227 BG = -14.84 - 124.3 * DS + 72.18 * S
38228 CG = 590.3 - 173.8 * S
38229 DG = 5.196 + 1.857 * S
38230 EG = -1.648 + 3.988 * S - 0.432 * S2
38231 ESG = 3.232 - 0.542 * S
38232 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38233
38234 END
38235
38236*
38237*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38238*
38239*$ CREATE PHO_DOR94FV.FOR
38240*COPY PHO_DOR94FV
38241CDECK ID>, PHO_DOR94FV
38242 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38243 IMPLICIT DOUBLE PRECISION (A - Z)
38244 SAVE
38245
38246 DX = SQRT (X)
38247 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38248
38249 END
38250
38251*$ CREATE PHO_DOR94FW.FOR
38252*COPY PHO_DOR94FW
38253CDECK ID>, PHO_DOR94FW
38254 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38255 & A,B,C,D,E,ES)
38256 IMPLICIT DOUBLE PRECISION (A - Z)
38257 SAVE
38258
38259 LX = LOG (1./X)
38260 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38261 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38262
38263 END
38264
38265*$ CREATE PHO_DOR94FS.FOR
38266*COPY PHO_DOR94FS
38267CDECK ID>, PHO_DOR94FS
38268 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38269 IMPLICIT DOUBLE PRECISION (A - Z)
38270 SAVE
38271
38272 DX = SQRT (X)
38273 LX = LOG (1./X)
38274 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38275 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38276
38277 END
38278
38279*$ CREATE PHO_DOR92LO.FOR
38280*COPY PHO_DOR92LO
38281CDECK ID>, PHO_DOR92LO
38282*
38283*
38284* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38285* *
38286* 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 *
38287* *
38288* FOR A DETAILED EXPLANATION SEE : *
38289* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38290* *
38291* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38292* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38293* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38294* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38295* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38296* *
38297* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38298* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38299* *
38300* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38301* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38302* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38303* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38304* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38305* *
38306* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38307* *
38308* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38309C
38310 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38311 IMPLICIT DOUBLE PRECISION (A - Z)
38312 SAVE
38313
38314 MU2 = 0.25
38315 LAM2 = 0.232 * 0.232
38316 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38317 S2 = S * S
38318 S3 = S2 * S
38319C...X * (UV + DV) :
38320 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38321 AKUD = 0.326
38322 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38323 BUD = 24.4 - 20.7 * S + 4.08 * S2
38324 DUD = 2.86 + 0.70 * S - 0.02 * S2
38325 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38326C...X * DV :
38327 ND = 0.579 + 0.283 * S + 0.047 * S2
38328 AKD = 0.523 - 0.015 * S
38329 AGD = 2.22 - 0.59 * S - 0.27 * S2
38330 BD = 5.95 - 6.19 * S + 1.55 * S2
38331 DD = 3.57 + 0.94 * S - 0.16 * S2
38332 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38333C...X * G :
38334 ALG = 0.558
38335 BEG = 1.218
38336 AKG = 1.00 - 0.17 * S
38337 BKG = 0.0
38338 AGG = 0.0 + 4.879 * S - 1.383 * S2
38339 BGG = 25.92 - 28.97 * S + 5.596 * S2
38340 CG = -25.69 + 23.68 * S - 1.975 * S2
38341 DG = 2.537 + 1.718 * S + 0.353 * S2
38342 EG = 0.595 + 2.138 * S
38343 ESG = 4.066
38344 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38345C...X * UBAR = X * DBAR :
38346 ALU = 1.396
38347 BEU = 1.331
38348 AKU = 0.412 - 0.171 * S
38349 BKU = 0.566 - 0.496 * S
38350 AGU = 0.363
38351 BGU = -1.196
38352 CU = 1.029 + 1.785 * S - 0.459 * S2
38353 DU = 4.696 + 2.109 * S
38354 EU = 3.838 + 1.944 * S
38355 ESU = 2.845
38356 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38357C...X * SBAR = X * S :
38358 SS = 0.0
38359 ALS = 0.803
38360 BES = 0.563
38361 AKS = 2.082 - 0.577 * S
38362 AGS = -3.055 + 1.024 * S ** 0.67
38363 BS = 27.4 - 20.0 * S ** 0.154
38364 DS = 6.22
38365 EST = 4.33 + 1.408 * S
38366 ESS = 8.27 - 0.437 * S
38367 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38368C...X * CBAR = X * C :
38369 SC = 0.888
38370 ALC = 1.01
38371 BEC = 0.37
38372 AKC = 0.0
38373 AGC = 0.0
38374 BC = 4.24 - 0.804 * S
38375 DC = 3.46 + 1.076 * S
38376 EC = 4.61 + 1.490 * S
38377 ESC = 2.555 + 1.961 * S
38378 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38379C...X * BBAR = X * B :
38380 SBO = 1.351
38381 ALB = 1.00
38382 BEB = 0.51
38383 AKB = 0.0
38384 AGB = 0.0
38385 BBO = 1.848
38386 DB = 2.929 + 1.396 * S
38387 EB = 4.71 + 1.514 * S
38388 ESB = 4.02 + 1.239 * S
38389 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38390
38391 END
38392
38393*$ CREATE PHO_DOR92HO.FOR
38394*COPY PHO_DOR92HO
38395CDECK ID>, PHO_DOR92HO
38396 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38397 IMPLICIT DOUBLE PRECISION (A - Z)
38398 SAVE
38399
38400 MU2 = 0.3
38401 LAM2 = 0.248 * 0.248
38402 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38403 DS = SQRT (S)
38404 S2 = S * S
38405 S3 = S2 * S
38406C...X * (UV + DV) :
38407 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38408 AKUD = 0.285
38409 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38410 BUD = 56.7 - 53.6 * S + 11.21 * S2
38411 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38412 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38413C...X * DV :
38414 ND = 0.459 + 0.315 * DS + 0.515 * S
38415 AKD = 0.624 - 0.031 * S
38416 AGD = 8.13 - 6.77 * DS + 0.46 * S
38417 BD = 6.59 - 12.83 * DS + 5.65 * S
38418 DD = 3.98 + 1.04 * S - 0.34 * S2
38419 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38420C...X * G :
38421 ALG = 1.128
38422 BEG = 1.575
38423 AKG = 0.323 + 1.653 * S
38424 BKG = 0.811 + 2.044 * S
38425 AGG = 0.0 + 1.963 * S - 0.519 * S2
38426 BGG = 0.078 + 6.24 * S
38427 CG = 30.77 - 24.19 * S
38428 DG = 3.188 + 0.720 * S
38429 EG = -0.881 + 2.687 * S
38430 ESG = 2.466
38431 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38432C...X * UBAR = X * DBAR :
38433 ALU = 0.594
38434 BEU = 0.614
38435 AKU = 0.636 - 0.084 * S
38436 BKU = 0.0
38437 AGU = 1.121 - 0.193 * S
38438 BGU = 0.751 - 0.785 * S
38439 CU = 8.57 - 1.763 * S
38440 DU = 10.22 + 0.668 * S
38441 EU = 3.784 + 1.280 * S
38442 ESU = 1.808 + 0.980 * S
38443 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38444C...X * SBAR = X * S :
38445 SS = 0.0
38446 ALS = 0.756
38447 BES = 0.101
38448 AKS = 2.942 - 1.016 * S
38449 AGS = -4.60 + 1.167 * S
38450 BS = 9.31 - 1.324 * S
38451 DS = 11.49 - 1.198 * S + 0.053 * S2
38452 EST = 2.630 + 1.729 * S
38453 ESS = 8.12
38454 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38455C...X * CBAR = X * C :
38456 SC = 0.820
38457 ALC = 0.98
38458 BEC = 0.0
38459 AKC = -0.625 - 0.523 * S
38460 AGC = 0.0
38461 BC = 1.896 + 1.616 * S
38462 DC = 4.12 + 0.683 * S
38463 EC = 4.36 + 1.328 * S
38464 ESC = 0.677 + 0.679 * S
38465 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38466C...X * BBAR = X * B :
38467 SBO = 1.297
38468 ALB = 0.99
38469 BEB = 0.0
38470 AKB = 0.0 - 0.193 * S
38471 AGB = 0.0
38472 BBO = 0.0
38473 DB = 3.447 + 0.927 * S
38474 EB = 4.68 + 1.259 * S
38475 ESB = 1.892 + 2.199 * S
38476 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38477
38478 END
38479
38480*$ CREATE PHO_DOR92FV.FOR
38481*COPY PHO_DOR92FV
38482CDECK ID>, PHO_DOR92FV
38483 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38484 IMPLICIT DOUBLE PRECISION (A - Z)
38485 SAVE
38486 DX = SQRT (X)
38487 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38488
38489 END
38490
38491*$ CREATE PHO_DOR92FW.FOR
38492*COPY PHO_DOR92FW
38493CDECK ID>, PHO_DOR92FW
38494 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38495 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38496 IMPLICIT DOUBLE PRECISION (A - Z)
38497 SAVE
38498 LX = LOG (1./X)
38499 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38500 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38501
38502 END
38503
38504*$ CREATE PHO_DOR92FS.FOR
38505*COPY PHO_DOR92FS
38506CDECK ID>, PHO_DOR92FS
38507 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38508 IMPLICIT DOUBLE PRECISION (A - Z)
38509 SAVE
38510
38511 DX = SQRT (X)
38512 LX = LOG (1./X)
38513 IF (S .LE. ST) THEN
38514 PHO_DOR92FS = 0.D0
38515 ELSE
38516 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38517 1 * EXP (-E + SQRT (ES * S**BE * LX))
38518 END IF
38519
38520 END
38521
38522*$ CREATE PHO_DORPLO.FOR
38523*COPY PHO_DORPLO
38524CDECK ID>, PHO_DORPLO
38525*
38526* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38527* *
38528* G R V - P I O N - P A R A M E T R I Z A T I O N S *
38529* *
38530* FOR A DETAILED EXPLANATION SEE : *
38531* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38532* *
38533* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38534* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38535* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38536* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38537* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38538* *
38539* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38540* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38541* *
38542* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38543* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38544* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38545* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38546* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38547* *
38548* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38549* *
38550* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38551C
38552 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38553 IMPLICIT DOUBLE PRECISION (A - Z)
38554 SAVE
38555
38556 MU2 = 0.25
38557 LAM2 = 0.232 * 0.232
38558 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38559 DS = SQRT (S)
38560 S2 = S * S
38561C...X * VALENCE :
38562 NV = 0.519 + 0.180 * S - 0.011 * S2
38563 AKV = 0.499 - 0.027 * S
38564 AGV = 0.381 - 0.419 * S
38565 DV = 0.367 + 0.563 * S
38566 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38567C...X * GLUON :
38568 ALG = 0.599
38569 BEG = 1.263
38570 AKG = 0.482 + 0.341 * DS
38571 BKG = 0.0
38572 AGG = 0.678 + 0.877 * S - 0.175 * S2
38573 BGG = 0.338 - 1.597 * S
38574 CG = 0.0 - 0.233 * S + 0.406 * S2
38575 DG = 0.390 + 1.053 * S
38576 EG = 0.618 + 2.070 * S
38577 ESG = 3.676
38578 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38579C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38580 SL = 0.0
38581 ALS = 0.55
38582 BES = 0.56
38583 AKS = 2.538 - 0.763 * S
38584 AGS = -0.748
38585 BS = 0.313 + 0.935 * S
38586 DS = 3.359
38587 EST = 4.433 + 1.301 * S
38588 ESS = 9.30 - 0.887 * S
38589 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38590C...X * CBAR = X * C :
38591 SC = 0.888
38592 ALC = 1.02
38593 BEC = 0.39
38594 AKC = 0.0
38595 AGC = 0.0
38596 BC = 1.008
38597 DC = 1.208 + 0.771 * S
38598 EC = 4.40 + 1.493 * S
38599 ESC = 2.032 + 1.901 * S
38600 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38601C...X * BBAR = X * B :
38602 SBO = 1.351
38603 ALB = 1.03
38604 BEB = 0.39
38605 AKB = 0.0
38606 AGB = 0.0
38607 BBO = 0.0
38608 DB = 0.697 + 0.855 * S
38609 EB = 4.51 + 1.490 * S
38610 ESB = 3.056 + 1.694 * S
38611 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38612
38613 END
38614
38615*$ CREATE PHO_DORPHO.FOR
38616*COPY PHO_DORPHO
38617CDECK ID>, PHO_DORPHO
38618 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38619 IMPLICIT DOUBLE PRECISION (A - Z)
38620 SAVE
38621
38622 MU2 = 0.3
38623 LAM2 = 0.248 * 0.248
38624 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38625 DS = SQRT (S)
38626 S2 = S * S
38627C...X * VALENCE :
38628 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38629 AKV = 0.505 - 0.033 * S
38630 AGV = 0.748 - 0.669 * DS - 0.133 * S
38631 DV = 0.365 + 0.197 * DS + 0.394 * S
38632 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38633C...X * GLUON :
38634 ALG = 1.096
38635 BEG = 1.371
38636 AKG = 0.437 - 0.689 * DS
38637 BKG = -0.631
38638 AGG = 1.324 - 0.441 * DS - 0.130 * S
38639 BGG = -0.955 + 0.259 * S
38640 CG = 1.075 - 0.302 * S
38641 DG = 1.158 + 1.229 * S
38642 EG = 0.0 + 2.510 * S
38643 ESG = 2.604 + 0.165 * S
38644 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38645C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38646 SL = 0.0
38647 ALS = 0.85
38648 BES = 0.96
38649 AKS = -0.350 + 0.806 * S
38650 AGS = -1.663
38651 BS = 3.148
38652 DS = 2.273 + 1.438 * S
38653 EST = 3.214 + 1.545 * S
38654 ESS = 1.341 + 1.938 * S
38655 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38656C...X * CBAR = X * C :
38657 SC = 0.820
38658 ALC = 0.98
38659 BEC = 0.0
38660 AKC = 0.0 - 0.457 * S
38661 AGC = 0.0
38662 BC = -1.00 + 1.40 * S
38663 DC = 1.318 + 0.584 * S
38664 EC = 4.45 + 1.235 * S
38665 ESC = 1.496 + 1.010 * S
38666 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38667C...X * BBAR = X * B :
38668 SBO = 1.297
38669 ALB = 0.99
38670 BEB = 0.0
38671 AKB = 0.0 - 0.172 * S
38672 AGB = 0.0
38673 BBO = 0.0
38674 DB = 1.447 + 0.485 * S
38675 EB = 4.79 + 1.164 * S
38676 ESB = 1.724 + 2.121 * S
38677 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38678
38679 END
38680
38681*$ CREATE PHO_DORFVP.FOR
38682*COPY PHO_DORFVP
38683CDECK ID>, PHO_DORFVP
38684 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38685 IMPLICIT DOUBLE PRECISION (A - Z)
38686 SAVE
38687
38688 DX = SQRT (X)
38689 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38690
38691 END
38692
38693*$ CREATE PHO_DORFGP.FOR
38694*COPY PHO_DORFGP
38695CDECK ID>, PHO_DORFGP
38696 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38697 & BG,C,D,E,ES)
38698 IMPLICIT DOUBLE PRECISION (A - Z)
38699 SAVE
38700
38701 DX = SQRT (X)
38702 LX = LOG (1./X)
38703 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38704 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38705
38706 END
38707
38708*$ CREATE PHO_DORFQP.FOR
38709*COPY PHO_DORFQP
38710CDECK ID>, PHO_DORFQP
38711 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,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 IF (S .LE. ST) THEN
38718 PHO_DORFQP = 0.0
38719 ELSE
38720 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38721 1 * EXP (-E + SQRT (ES * S**BE * LX))
38722 END IF
38723
38724 END
38725
38726*$ CREATE PHO_DORGLO.FOR
38727*COPY PHO_DORGLO
38728CDECK ID>, PHO_DORGLO
38729* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38730* *
38731* 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 *
38732* *
38733* FOR A DETAILED EXPLANATION SEE : *
38734* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38735* *
38736* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38737* *
38738* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38739* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38740* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38741* *
38742* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38743* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38744* *
38745* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38746* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38747* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38748* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38749* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38750* *
38751* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38752* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38753* *
38754* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38755C
38756 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38757 IMPLICIT DOUBLE PRECISION (A - Z)
38758 SAVE
38759
38760 MU2 = 0.25
38761 LAM2 = 0.232 * 0.232
38762 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38763 SS = SQRT (S)
38764 S2 = S * S
38765C...X * U = X * UBAR :
38766 AL = 1.717
38767 BE = 0.641
38768 AK = 0.500 - 0.176 * S
38769 BK = 15.00 - 5.687 * SS - 0.552 * S2
38770 AG = 0.235 + 0.046 * SS
38771 BG = 0.082 - 0.051 * S + 0.168 * S2
38772 C = 0.0 + 0.459 * S
38773 D = 0.354 - 0.061 * S
38774 E = 4.899 + 1.678 * S
38775 ES = 2.046 + 1.389 * S
38776 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38777C...X * D = X * DBAR :
38778 AL = 1.549
38779 BE = 0.782
38780 AK = 0.496 + 0.026 * S
38781 BK = 0.685 - 0.580 * SS + 0.608 * S2
38782 AG = 0.233 + 0.302 * S
38783 BG = 0.0 - 0.818 * S + 0.198 * S2
38784 C = 0.114 + 0.154 * S
38785 D = 0.405 - 0.195 * S + 0.046 * S2
38786 E = 4.807 + 1.226 * S
38787 ES = 2.166 + 0.664 * S
38788 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38789C...X * G :
38790 AL = 0.676
38791 BE = 1.089
38792 AK = 0.462 - 0.524 * SS
38793 BK = 5.451 - 0.804 * S2
38794 AG = 0.535 - 0.504 * SS + 0.288 * S2
38795 BG = 0.364 - 0.520 * S
38796 C = -0.323 + 0.115 * S2
38797 D = 0.233 + 0.790 * S - 0.139 * S2
38798 E = 0.893 + 1.968 * S
38799 ES = 3.432 + 0.392 * S
38800 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38801C...X * S = X * SBAR :
38802 SF = 0.0
38803 AL = 1.609
38804 BE = 0.962
38805 AK = 0.470 - 0.099 * S2
38806 BK = 3.246
38807 AG = 0.121 - 0.068 * SS
38808 BG = -0.090 + 0.074 * S
38809 C = 0.062 + 0.034 * S
38810 D = 0.0 + 0.226 * S - 0.060 * S2
38811 E = 4.288 + 1.707 * S
38812 ES = 2.122 + 0.656 * S
38813 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38814C...X * C = X * CBAR :
38815 SF = 0.888
38816 AL = 0.970
38817 BE = 0.545
38818 AK = 1.254 - 0.251 * S
38819 BK = 3.932 - 0.327 * S2
38820 AG = 0.658 + 0.202 * S
38821 BG = -0.699
38822 C = 0.965
38823 D = 0.0 + 0.141 * S - 0.027 * S2
38824 E = 4.911 + 0.969 * S
38825 ES = 2.796 + 0.952 * S
38826 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38827C...X * B = X * BBAR :
38828 SF = 1.351
38829 AL = 1.016
38830 BE = 0.338
38831 AK = 1.961 - 0.370 * S
38832 BK = 0.923 + 0.119 * S
38833 AG = 0.815 + 0.207 * S
38834 BG = -2.275
38835 C = 1.480
38836 D = -0.223 + 0.173 * S
38837 E = 5.426 + 0.623 * S
38838 ES = 3.819 + 0.901 * S
38839 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38840
38841 END
38842
38843*$ CREATE PHO_DORGHO.FOR
38844*COPY PHO_DORGHO
38845CDECK ID>, PHO_DORGHO
38846 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38847 IMPLICIT DOUBLE PRECISION (A - Z)
38848 SAVE
38849
38850 MU2 = 0.3
38851 LAM2 = 0.248 * 0.248
38852 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38853 SS = SQRT (S)
38854 S2 = S * S
38855C...X * U = X * UBAR :
38856 AL = 0.583
38857 BE = 0.688
38858 AK = 0.449 - 0.025 * S - 0.071 * S2
38859 BK = 5.060 - 1.116 * SS
38860 AG = 0.103
38861 BG = 0.319 + 0.422 * S
38862 C = 1.508 + 4.792 * S - 1.963 * S2
38863 D = 1.075 + 0.222 * SS - 0.193 * S2
38864 E = 4.147 + 1.131 * S
38865 ES = 1.661 + 0.874 * S
38866 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38867C...X * D = X * DBAR :
38868 AL = 0.591
38869 BE = 0.698
38870 AK = 0.442 - 0.132 * S - 0.058 * S2
38871 BK = 5.437 - 1.916 * SS
38872 AG = 0.099
38873 BG = 0.311 - 0.059 * S
38874 C = 0.800 + 0.078 * S - 0.100 * S2
38875 D = 0.862 + 0.294 * SS - 0.184 * S2
38876 E = 4.202 + 1.352 * S
38877 ES = 1.841 + 0.990 * S
38878 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38879C...X * G :
38880 AL = 1.161
38881 BE = 1.591
38882 AK = 0.530 - 0.742 * SS + 0.025 * S2
38883 BK = 5.662
38884 AG = 0.533 - 0.281 * SS + 0.218 * S2
38885 BG = 0.025 - 0.518 * S + 0.156 * S2
38886 C = -0.282 + 0.209 * S2
38887 D = 0.107 + 1.058 * S - 0.218 * S2
38888 E = 0.0 + 2.704 * S
38889 ES = 3.071 - 0.378 * S
38890 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38891C...X * S = X * SBAR :
38892 SF = 0.0
38893 AL = 0.635
38894 BE = 0.456
38895 AK = 1.770 - 0.735 * SS - 0.079 * S2
38896 BK = 3.832
38897 AG = 0.084 - 0.023 * S
38898 BG = 0.136
38899 C = 2.119 - 0.942 * S + 0.063 * S2
38900 D = 1.271 + 0.076 * S - 0.190 * S2
38901 E = 4.604 + 0.737 * S
38902 ES = 1.641 + 0.976 * S
38903 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38904C...X * C = X * CBAR :
38905 SF = 0.820
38906 AL = 0.926
38907 BE = 0.152
38908 AK = 1.142 - 0.175 * S
38909 BK = 3.276
38910 AG = 0.504 + 0.317 * S
38911 BG = -0.433
38912 C = 3.334
38913 D = 0.398 + 0.326 * S - 0.107 * S2
38914 E = 5.493 + 0.408 * S
38915 ES = 2.426 + 1.277 * S
38916 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38917C...X * B = X * BBAR :
38918 SF = 1.297
38919 AL = 0.969
38920 BE = 0.266
38921 AK = 1.953 - 0.391 * S
38922 BK = 1.657 - 0.161 * S
38923 AG = 1.076 + 0.034 * S
38924 BG = -2.015
38925 C = 1.662
38926 D = 0.353 + 0.016 * S
38927 E = 5.713 + 0.249 * S
38928 ES = 3.456 + 0.673 * S
38929 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38930
38931 END
38932
38933*$ CREATE PHO_DORGH0.FOR
38934*COPY PHO_DORGH0
38935CDECK ID>, PHO_DORGH0
38936 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38937 IMPLICIT DOUBLE PRECISION (A - Z)
38938 SAVE
38939
38940 MU2 = 0.3
38941 LAM2 = 0.248 * 0.248
38942 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38943 SS = SQRT (S)
38944 S2 = S * S
38945C...X * U = X * UBAR :
38946 AL = 1.447
38947 BE = 0.848
38948 AK = 0.527 + 0.200 * S - 0.107 * S2
38949 BK = 7.106 - 0.310 * SS - 0.786 * S2
38950 AG = 0.197 + 0.533 * S
38951 BG = 0.062 - 0.398 * S + 0.109 * S2
38952 C = 0.755 * S - 0.112 * S2
38953 D = 0.318 - 0.059 * S
38954 E = 4.225 + 1.708 * S
38955 ES = 1.752 + 0.866 * S
38956 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38957C...X * D = X * DBAR :
38958 AL = 1.424
38959 BE = 0.770
38960 AK = 0.500 + 0.067 * SS - 0.055 * S2
38961 BK = 0.376 - 0.453 * SS + 0.405 * S2
38962 AG = 0.156 + 0.184 * S
38963 BG = 0.0 - 0.528 * S + 0.146 * S2
38964 C = 0.121 + 0.092 * S
38965 D = 0.379 - 0.301 * S + 0.081 * S2
38966 E = 4.346 + 1.638 * S
38967 ES = 1.645 + 1.016 * S
38968 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38969C...X * G :
38970 AL = 0.661
38971 BE = 0.793
38972 AK = 0.537 - 0.600 * SS
38973 BK = 6.389 - 0.953 * S2
38974 AG = 0.558 - 0.383 * SS + 0.261 * S2
38975 BG = 0.0 - 0.305 * S
38976 C = -0.222 + 0.078 * S2
38977 D = 0.153 + 0.978 * S - 0.209 * S2
38978 E = 1.429 + 1.772 * S
38979 ES = 3.331 + 0.806 * S
38980 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38981C...X * S = X * SBAR :
38982 SF = 0.0
38983 AL = 1.578
38984 BE = 0.863
38985 AK = 0.622 + 0.332 * S - 0.300 * S2
38986 BK = 2.469
38987 AG = 0.211 - 0.064 * SS - 0.018 * S2
38988 BG = -0.215 + 0.122 * S
38989 C = 0.153
38990 D = 0.0 + 0.253 * S - 0.081 * S2
38991 E = 3.990 + 2.014 * S
38992 ES = 1.720 + 0.986 * S
38993 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38994C...X * C = X * CBAR :
38995 SF = 0.820
38996 AL = 0.929
38997 BE = 0.381
38998 AK = 1.228 - 0.231 * S
38999 BK = 3.806 - 0.337 * S2
39000 AG = 0.932 + 0.150 * S
39001 BG = -0.906
39002 C = 1.133
39003 D = 0.0 + 0.138 * S - 0.028 * S2
39004 E = 5.588 + 0.628 * S
39005 ES = 2.665 + 1.054 * S
39006 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39007C...X * B = X * BBAR :
39008 SF = 1.297
39009 AL = 0.970
39010 BE = 0.207
39011 AK = 1.719 - 0.292 * S
39012 BK = 0.928 + 0.096 * S
39013 AG = 0.845 + 0.178 * S
39014 BG = -2.310
39015 C = 1.558
39016 D = -0.191 + 0.151 * S
39017 E = 6.089 + 0.282 * S
39018 ES = 3.379 + 1.062 * S
39019 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39020
39021 END
39022
39023*$ CREATE PHO_DORGF.FOR
39024*COPY PHO_DORGF
39025CDECK ID>, PHO_DORGF
39026 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39027 & AG,BG,C,D,E,ES)
39028 IMPLICIT DOUBLE PRECISION (A - Z)
39029 SAVE
39030
39031 SX = SQRT (X)
39032 LX = LOG (1./X)
39033 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39034 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39035
39036 END
39037
39038*$ CREATE PHO_DORGFS.FOR
39039*COPY PHO_DORGFS
39040CDECK ID>, PHO_DORGFS
39041 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39042 & C,D,E,ES)
39043 IMPLICIT DOUBLE PRECISION (A - Z)
39044 SAVE
39045
39046 IF (S .LE. SF) THEN
39047 PHO_DORGFS = 0.0
39048 ELSE
39049 SX = SQRT (X)
39050 LX = LOG (1./X)
39051 DS = S - SF
39052 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39053 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39054 END IF
39055
39056 END
39057
39058*$ CREATE PHO_DORGLV.FOR
39059*COPY PHO_DORGLV
39060CDECK ID>, PHO_DORGLV
39061* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39062* *
39063* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39064* *
39065* FOR A DETAILED EXPLANATION SEE *
39066* M. GLUECK, E.REYA, M. STRATMANN : *
39067* PHYS. REV. D51 (1995) 3220 *
39068* *
39069* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39070* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39071* AND (!) Q**2 > 5 P**2 *
39072* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39073* P**2 = 0 <=> REAL PHOTON *
39074* X BETWEEN 1.E-4 AND 1. *
39075* *
39076* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39077* M(C) = 1.5, M(B) = 4.5 *
39078* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39079* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39080* LAMBDA(5) = 0.153, *
39081* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39082* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39083* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39084* *
39085* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39086* Marco.Stratmann@durham.ac.uk *
39087* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39088*
39089*...INPUT PARAMETERS :
39090*
39091* X = MOMENTUM FRACTION
39092* Q2 = SCALE Q**2 IN GEV**2
39093* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39094*
39095*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39096*
39097********************************************************
39098* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39099 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39100 implicit double precision (a-z)
39101 save
39102
39103C input/output channels
39104 INTEGER LI,LO
39105 COMMON /POINOU/ LI,LO
39106
39107 integer check
39108c
39109c check limits :
39110c
39111 check=0
39112 if(x.lt.0.0001d0) check=1
39113 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39114 if(q2.lt.5.d0*p2) check=1
39115c
39116c calculate distributions
39117c
39118 if(check.eq.0) then
39119 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39120 else
39121 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39122 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39123 endif
39124
39125 end
39126
39127*$ CREATE PHO_grscalc.FOR
39128*COPY PHO_grscalc
39129CDECK ID>, PHO_grscalc
39130 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39131 implicit double precision (a-z)
39132 save
39133
39134 dimension u1(40),ds1(40),g1(40)
39135 dimension ud2(20),s2(20),g2(20)
39136 dimension up0(20),dsp0(20),gp0(20)
454792a9 39137CPH save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
9aaba0d6 39138c
39139 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39140 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39141 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39142 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39143 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39144 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39145 & 0.622d0,0.227d0,-0.184d0/
39146 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39147 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39148 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39149 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39150 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39151 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39152 & 0.245d0,-0.171d0/
39153 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39154 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39155 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39156 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39157 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39158 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39159 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39160 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39161 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39162 & -0.614d0,3.548d0/
39163 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39164 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39165 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39166 & -0.48d0,3.401d0/
39167 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39168 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39169 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39170 & -0.079d0/
39171 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39172 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39173 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39174 & 2.294d0/
39175 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39176 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39177 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39178 & 0.814d0,1.531d0,0.124d0/
39179 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39180 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39181 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39182 & 2.264d0,0.2675d0/
39183c
39184 mu2=0.25d0
39185 lam2=0.232d0*0.232d0
39186c
39187 if(p2.le.0.25d0) then
39188 s=log(log(q2/lam2)/log(mu2/lam2))
39189 lp1=0.d0
39190 lp2=0.d0
39191 else
39192 s=log(log(q2/lam2)/log(p2/lam2))
39193 lp1=log(p2/mu2)*log(p2/mu2)
39194 lp2=log(p2/mu2+log(p2/mu2))
39195 endif
39196c
39197 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39198 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39199 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39200 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39201 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39202 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39203 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39204 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39205 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39206 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39207 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39208 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39209 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39210 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39211 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39212 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39213 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39214 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39215 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39216 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39217 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39218c
39219 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39220 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39221 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39222 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39223 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39224 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39225 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39226 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39227 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39228 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39229 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39230 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39231 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39232 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39233 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39234 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39235 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39236 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39237 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39238 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39239 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39240c
39241 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39242 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39243 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39244 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39245 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39246 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39247 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39248 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39249 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39250 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39251 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39252 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39253 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39254 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39255 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39256 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39257 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39258 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39259 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39260 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39261 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39262c
39263 s=log(log(q2/lam2)/log(mu2/lam2))
39264 suppr=1.d0/(1.d0+p2/0.59d0)**2
39265c
39266 alp=ud2(1)
39267 bet=ud2(2)
39268 a=ud2(3)+ud2(4)*s
39269 ga=ud2(5)+ud2(6)*s**0.5
39270 gc=ud2(7)+ud2(8)*s
39271 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39272 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39273 gd=ud2(15)+ud2(16)*s
39274 ge=ud2(17)+ud2(18)*s
39275 gep=ud2(19)+ud2(20)*s
39276 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39277c
39278 alp=s2(1)
39279 bet=s2(2)
39280 a=s2(3)+s2(4)*s
39281 ga=s2(5)+s2(6)*s**0.5
39282 gc=s2(7)+s2(8)*s
39283 b=s2(9)+s2(10)*s+s2(11)*s**2
39284 gb=s2(12)+s2(13)*s+s2(14)*s**2
39285 gd=s2(15)+s2(16)*s
39286 ge=s2(17)+s2(18)*s
39287 gep=s2(19)+s2(20)*s
39288 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39289c
39290 alp=g2(1)
39291 bet=g2(2)
39292 a=g2(3)+g2(4)*s**0.5
39293 b=g2(5)+g2(6)*s**2
39294 gb=g2(7)+g2(8)*s
39295 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39296 gc=g2(12)+g2(13)*s**2
39297 gd=g2(14)+g2(15)*s+g2(16)*s**2
39298 ge=g2(17)+g2(18)*s
39299 gep=g2(19)+g2(20)*s
39300 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39301c
39302 ugam=upart1+udpart2
39303 dgam=dspart1+udpart2
39304 sgam=dspart1+spart2
39305 ggam=gpart1+gpart2
39306c
39307 end
39308
39309*$ CREATE PHO_grsf1.FOR
39310*COPY PHO_grsf1
39311CDECK ID>, PHO_grsf1
39312 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39313 & ge,gep)
39314 implicit double precision (a-z)
39315 save
39316
39317 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39318 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39319 & (1.d0-x)**gd
39320
39321 end
39322
39323*$ CREATE PHO_grsf2.FOR
39324*COPY PHO_grsf2
39325CDECK ID>, PHO_grsf2
39326 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39327 & ge,gep)
39328 implicit double precision (a-z)
39329 save
39330
39331 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39332 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39333 & (1.d0-x)**gd
39334
39335 end
39336
39337*$ CREATE PHO_CKMTPA.FOR
39338*COPY PHO_CKMTPA
39339CDECK ID>, PHO_CKMTPA
39340 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39341C**********************************************************************
39342C
39343C PDF based on Regge theory, evolved with .... by ....
39344C
39345C input: IPAR 2212 proton (not installed)
39346C 990 Pomeron
39347C
39348C output: parameters of parametrization
39349C
39350C**********************************************************************
39351 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39352 SAVE
39353
39354 CHARACTER*8 PDFNA
39355
39356C input/output channels
39357 INTEGER LI,LO
39358 COMMON /POINOU/ LI,LO
39359
39360 REAL PROP(40),POMP(40)
39361 DATA PROP /
39362 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39363 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39364 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39365 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39366 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39367 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39368 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39369 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39370 DATA POMP /
39371 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39372 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39373 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39374 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39375 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39376 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39377 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39378 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39379
39380 IF(IPA.EQ.2212) THEN
39381 ALA =PROP(1)
39382 Q2MI = PROP(39)
39383 Q2MA = PROP(40)
39384 PDFNA = 'CKMT-PRO'
39385 ELSE IF(IPA.EQ.990) THEN
39386 ALA = POMP(1)
39387 Q2MI = POMP(39)
39388 Q2MA = POMP(40)
39389 PDFNA = 'CKMT-POM'
39390 ELSE
39391 WRITE(LO,'(1X,A,I7)')
39392 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39393 STOP
39394 ENDIF
39395 XMI = 1.D-4
39396 XMA = 1.D0
39397 END
39398
39399*$ CREATE PHO_CKMTPD.FOR
39400*COPY PHO_CKMTPD
39401CDECK ID>, PHO_CKMTPD
39402 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39403C**********************************************************************
39404C
39405C PDF based on Regge theory, evolved with .... by ....
39406C
39407C input: IPAR 2212 proton (not installed)
39408C 990 Pomeron
39409C
39410C output: PD(-6:6) x*f(x) parton distribution functions
39411C (PDFLIB convention: d = PD(1), u = PD(2) )
39412C
39413C**********************************************************************
39414 SAVE
39415
39416C input/output channels
39417 INTEGER LI,LO
39418 COMMON /POINOU/ LI,LO
39419
39420 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39421 DIMENSION QQ(7)
39422
39423 Q2=SNGL(SCALE2)
39424 Q1S=Q2
39425 XX=SNGL(X)
39426C QCD lambda for evolution
39427 OWLAM = 0.23D0
39428 OWLAM2=OWLAM**2
39429C Q0**2 for evolution
39430 Q02 = 2.D0
39431C
39432C
39433C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39434C q(6)=x*charm, q(7)=x*gluon
39435C
39436 SB=0.
39437 IF(Q2-Q02) 1,1,2
39438 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39439 1 CONTINUE
39440 IF(IPAR.EQ.2212) THEN
39441* CALL PHO_CKMTPR(XX,SB,QQ
39442 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39443 CALL PHO_ABORT
39444 ELSE
39445 CALL PHO_CKMTPO(XX,SB,QQ)
39446 ENDIF
39447C
39448 PD(-6) = 0.D0
39449 PD(-5) = 0.D0
39450 PD(-4) = DBLE(QQ(6))
39451 PD(-3) = DBLE(QQ(3))
39452 PD(-2) = DBLE(QQ(4))
39453 PD(-1) = DBLE(QQ(5))
39454 PD(0) = DBLE(QQ(7))
39455 PD(1) = DBLE(QQ(2))
39456 PD(2) = DBLE(QQ(1))
39457 PD(3) = DBLE(QQ(3))
39458 PD(4) = DBLE(QQ(6))
39459 PD(5) = 0.D0
39460 PD(6) = 0.D0
39461 IF(IPAR.EQ.990) THEN
39462 CDN = (PD(1)-PD(-1))/2.D0
39463 CUP = (PD(2)-PD(-2))/2.D0
39464 PD(-1) = PD(-1) + CDN
39465 PD(-2) = PD(-2) + CUP
39466 PD(1) = PD(-1)
39467 PD(2) = PD(-2)
39468 ENDIF
39469 END
39470
39471*$ CREATE PHO_CKMTPO.FOR
39472*COPY PHO_CKMTPO
39473CDECK ID>, PHO_CKMTPO
39474 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39475C**********************************************************************
39476C
39477C calculation partons in Pomeron
39478C
39479C**********************************************************************
39480 SAVE
39481
39482 DIMENSION QQ(7)
39483
39484C input/output channels
39485 INTEGER LI,LO
39486 COMMON /POINOU/ LI,LO
39487
39488 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39489 EQUIVALENCE (GF(1,1,1),DL(1))
39490 DATA DELTA/.10/
39491
39492C RNG= -.5
39493C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39494C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39495 DATA (DL(K),K= 1, 85) /
39496 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39497 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39498 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39499 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39500 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39501 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39502 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39503 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39504 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39505 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39506 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39507 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39508 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39509 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39510 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39511 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39512 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39513 DATA (DL(K),K= 86, 170) /
39514 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39515 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39516 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39517 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39518 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39519 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39520 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39521 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39522 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39523 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39524 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39525 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39526 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39527 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39528 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39529 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39530 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39531 DATA (DL(K),K= 171, 255) /
39532 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39533 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39534 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39535 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39536 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39537 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39538 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39539 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39540 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39541 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39542 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39543 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39544 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39545 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39546 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39547 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39548 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39549 DATA (DL(K),K= 256, 340) /
39550 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39551 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39552 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39553 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39554 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39555 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39556 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39557 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39558 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39559 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39560 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39561 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39562 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39563 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39564 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39565 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39566 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39567 DATA (DL(K),K= 341, 425) /
39568 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39569 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39570 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39571 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39572 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39573 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39574 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39575 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39576 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39577 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39578 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39579 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39580 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39581 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39582 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39583 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39584 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39585 DATA (DL(K),K= 426, 510) /
39586 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39587 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39588 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39589 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39590 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39591 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39592 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39593 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39594 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39595 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39596 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39597 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39598 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39599 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39600 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39601 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39602 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39603 DATA (DL(K),K= 511, 595) /
39604 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39605 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39606 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39607 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39608 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39609 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39610 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39611 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39612 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39613 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39614 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39615 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39616 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39617 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39618 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39619 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39620 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39621 DATA (DL(K),K= 596, 680) /
39622 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39623 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39624 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39625 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39626 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39627 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39628 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39629 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39630 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39631 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39632 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39633 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39634 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39635 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39636 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39637 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39638 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39639 DATA (DL(K),K= 681, 765) /
39640 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39641 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39642 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39643 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39644 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39645 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39646 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39647 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39648 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39649 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39650 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39651 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39652 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39653 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39654 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39655 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39656 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39657 DATA (DL(K),K= 766, 850) /
39658 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39659 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39660 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39661 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39662 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39663 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39664 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39665 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39666 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39667 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39668 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39669 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39670 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39671 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39672 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39673 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39674 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39675 DATA (DL(K),K= 851, 935) /
39676 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39677 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39678 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39679 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39680 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39681 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39682 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39683 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39684 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39685 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39686 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39687 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39688 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39689 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39690 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39691 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39692 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39693 DATA (DL(K),K= 936, 1020) /
39694 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39695 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39696 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39697 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39698 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39699 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39700 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39701 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39702 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39703 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39704 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39705 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39706 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39707 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39708 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39709 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39710 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39711 DATA (DL(K),K= 1021, 1105) /
39712 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39713 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39714 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39715 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39716 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39717 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39718 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39719 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39720 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39721 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39722 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39723 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39724 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39725 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39726 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39727 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39728 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39729 DATA (DL(K),K= 1106, 1190) /
39730 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39731 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39732 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39733 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39734 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39735 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39736 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39737 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39738 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39739 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39740 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39741 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39742 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39743 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39744 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39745 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39746 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39747 DATA (DL(K),K= 1191, 1275) /
39748 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39749 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39750 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39751 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39752 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39753 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39754 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39755 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39756 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39757 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39758 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39759 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39760 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39761 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39762 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39763 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39764 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39765 DATA (DL(K),K= 1276, 1360) /
39766 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39767 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39768 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39769 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39770 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39771 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39772 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39773 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39774 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39775 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39776 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39777 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39778 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39779 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39780 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39781 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39782 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39783 DATA (DL(K),K= 1361, 1445) /
39784 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39785 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39786 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39787 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39788 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39789 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39790 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39791 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39792 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39793 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39794 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39795 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39796 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39797 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39798 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39799 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39800 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39801 DATA (DL(K),K= 1446, 1530) /
39802 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39803 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39804 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39805 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39806 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39807 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39808 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39809 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39810 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39811 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39812 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39813 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39814 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39815 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39816 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39817 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39818 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39819 DATA (DL(K),K= 1531, 1615) /
39820 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39821 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39822 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39823 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39824 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39825 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39826 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39827 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39828 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39829 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39830 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39831 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39832 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39833 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39834 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39835 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39836 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39837 DATA (DL(K),K= 1616, 1700) /
39838 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39839 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39840 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39841 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39842 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39843 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39844 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39845 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39846 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39847 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39848 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39849 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39850 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39851 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39852 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39853 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39854 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39855 DATA (DL(K),K= 1701, 1785) /
39856 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39857 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39858 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39859 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39860 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39861 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39862 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39863 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39864 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39865 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39866 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39867 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39868 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39869 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39870 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39871 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39872 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39873 DATA (DL(K),K= 1786, 1870) /
39874 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39875 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39876 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39877 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39878 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39879 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39880 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39881 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39882 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39883 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39884 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39885 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39886 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39887 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39888 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39889 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39890 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39891 DATA (DL(K),K= 1871, 1955) /
39892 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39893 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39894 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39895 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39896 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39897 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39898 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39899 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39900 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39901 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39902 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39903 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39904 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39905 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39906 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39907 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39908 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39909 DATA (DL(K),K= 1956, 2040) /
39910 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39911 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39912 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39913 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39914 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39915 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39916 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39917 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39918 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39919 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39920 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39921 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39922 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39923 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39924 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39925 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39926 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39927 DATA (DL(K),K= 2041, 2125) /
39928 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39929 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39930 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39931 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39932 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39933 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39934 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39935 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39936 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39937 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39938 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39939 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39940 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39941 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39942 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39943 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39944 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39945 DATA (DL(K),K= 2126, 2210) /
39946 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39947 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39948 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39949 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39950 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39951 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39952 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39953 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39954 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39955 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39956 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39957 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39958 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39959 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39960 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39961 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39962 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39963 DATA (DL(K),K= 2211, 2295) /
39964 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39965 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39966 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39967 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39968 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39969 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39971 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39972 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39973 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39974 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39975 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39976 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39977 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
39978 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
39979 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
39980 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
39981 DATA (DL(K),K= 2296, 2380) /
39982 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
39983 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
39984 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
39985 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
39986 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
39987 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
39988 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
39989 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
39990 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
39991 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
39992 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
39993 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
39994 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
39995 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
39996 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
39997 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
39998 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39999 DATA (DL(K),K= 2381, 2465) /
40000 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40001 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40002 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40003 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40005 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40006 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40007 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40008 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40009 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40010 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40011 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40012 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40013 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40014 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40015 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40016 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40017 DATA (DL(K),K= 2466, 2550) /
40018 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40019 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40020 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40021 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40022 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40023 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40024 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40025 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40026 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40027 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40028 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40029 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40030 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40031 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40032 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40033 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40034 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40035 DATA (DL(K),K= 2551, 2635) /
40036 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40037 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40039 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40040 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40041 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40042 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40043 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40044 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40045 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40046 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40047 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40048 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40049 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40050 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40051 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40052 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40053 DATA (DL(K),K= 2636, 2720) /
40054 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40055 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40056 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40057 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40058 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40059 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40060 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40061 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40062 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40063 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40064 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40065 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40066 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40067 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40068 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40069 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40070 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40071 DATA (DL(K),K= 2721, 2805) /
40072 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40073 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40074 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40075 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40076 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40077 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40078 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40079 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40080 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40081 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40082 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40083 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40084 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40085 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40086 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40087 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40088 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40089 DATA (DL(K),K= 2806, 2890) /
40090 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40091 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40092 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40093 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40094 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40095 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40096 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40097 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40098 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40099 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40100 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40101 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40102 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40103 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40104 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40105 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40106 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40107 DATA (DL(K),K= 2891, 2975) /
40108 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40109 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40110 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40111 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40112 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40113 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40114 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40115 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40116 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40117 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40118 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40119 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40120 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40121 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40122 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40123 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40124 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40125 DATA (DL(K),K= 2976, 3060) /
40126 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40127 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40128 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40129 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40130 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40131 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40132 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40133 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40134 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40135 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40136 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40137 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40138 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40139 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40140 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40141 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40142 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40143 DATA (DL(K),K= 3061, 3145) /
40144 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40145 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40146 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40147 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40148 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40149 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40150 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40151 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40152 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40153 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40154 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40155 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40156 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40157 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40158 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40159 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40160 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40161 DATA (DL(K),K= 3146, 3230) /
40162 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40163 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40164 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40165 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40166 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40167 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40168 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40169 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40170 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40171 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40172 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40174 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40175 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40176 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40177 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40178 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40179 DATA (DL(K),K= 3231, 3315) /
40180 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40181 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40182 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40183 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40184 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40185 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40186 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40187 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40188 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40189 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40190 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40191 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40192 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40193 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40194 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40195 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40196 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40197 DATA (DL(K),K= 3316, 3400) /
40198 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40199 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40200 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40201 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40202 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40203 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40204 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40205 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40206 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40208 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40209 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40210 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40211 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40212 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40213 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40214 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40215 DATA (DL(K),K= 3401, 3485) /
40216 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40217 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40218 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40219 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40220 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40221 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40222 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40223 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40224 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40225 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40226 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40227 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40228 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40229 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40230 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40231 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40232 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40233 DATA (DL(K),K= 3486, 3570) /
40234 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40235 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40236 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40237 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40238 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40239 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40240 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40242 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40243 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40244 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40245 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40246 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40247 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40248 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40249 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40250 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40251 DATA (DL(K),K= 3571, 3655) /
40252 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40253 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40254 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40255 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40256 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40257 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40258 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40259 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40260 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40261 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40262 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40263 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40264 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40265 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40266 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40267 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40268 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40269 DATA (DL(K),K= 3656, 3740) /
40270 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40271 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40272 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40273 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40274 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40276 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40277 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40278 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40279 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40280 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40281 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40282 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40283 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40284 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40285 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40286 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40287 DATA (DL(K),K= 3741, 3825) /
40288 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40289 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40290 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40291 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40292 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40293 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40294 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40295 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40296 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40297 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40298 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40299 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40300 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40301 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40302 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40303 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40304 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40305 DATA (DL(K),K= 3826, 3910) /
40306 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40307 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40308 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40310 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40311 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40312 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40313 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40314 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40315 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40316 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40317 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40318 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40319 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40320 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40321 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40322 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40323 DATA (DL(K),K= 3911, 3995) /
40324 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40325 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40326 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40327 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40328 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40329 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40330 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40331 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40332 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40333 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40334 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40335 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40336 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40337 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40338 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40339 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40340 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40341 DATA (DL(K),K= 3996, 4000) /
40342 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40343
40344 DO 10 I=1,7
40345 QQ(I) = 0.
40346 10 CONTINUE
40347 IF(X.GT.0.9985) RETURN
40348
40349 IS = S/DELTA+1
40350 IS = MIN(IS,19)
40351 IS1 = IS+1
40352 DO 20 I=1,7
40353 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40354 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40355 DO 30 L=1,25
40356 F1(L)=GF(I,IS,L)
40357 F2(L)=GF(I,IS1,L)
40358 30 CONTINUE
40359 S1=(IS-1)*DELTA
40360 S2=S1+DELTA
40361 A1 = PHO_CKMTFV(X,F1)
40362 A2 = PHO_CKMTFV(X,F2)
40363 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40364 19 CONTINUE
40365 20 CONTINUE
40366
40367 END
40368
40369*$ CREATE PHO_CKMTFV.FOR
40370*COPY PHO_CKMTFV
40371CDECK ID>, PHO_CKMTFV
40372 REAL FUNCTION PHO_CKMTFV(X,FVL)
40373C**********************************************************************
40374C
40375C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40376C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40377C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40378C IN MAIN ROUTINE.
40379C
40380C**********************************************************************
40381 SAVE
40382
40383 DIMENSION FVL(25),XGRID(25)
40384
40385C input/output channels
40386 INTEGER LI,LO
40387 COMMON /POINOU/ LI,LO
40388
40389 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40390 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40391
40392 PHO_CKMTFV=0.
40393 DO 1 I=1,NX
40394 IF(X.LT.XGRID(I)) GO TO 2
40395 1 CONTINUE
40396 2 I=I-1
40397 IF(I.EQ.0) THEN
40398 I=I+1
40399 ELSE IF(I.GT.23) THEN
40400 I=23
40401 ENDIF
40402 J=I+1
40403 K=J+1
40404 AXI=LOG(XGRID(I))
40405 BXI=LOG(1.-XGRID(I))
40406 AXJ=LOG(XGRID(J))
40407 BXJ=LOG(1.-XGRID(J))
40408 AXK=LOG(XGRID(K))
40409 BXK=LOG(1.-XGRID(K))
40410 FI=LOG(ABS(FVL(I)) +1.E-15)
40411 FJ=LOG(ABS(FVL(J)) +1.E-16)
40412 FK=LOG(ABS(FVL(K)) +1.E-17)
40413 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40414 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40415 $ BXI))/DET
40416 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40417 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40418 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40419 1RETURN
40420C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40421C WRITE(LO,2001) X,FVL
40422C 2001 FORMAT(8E12.4)
40423C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40424C ENDIF
40425 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40426
40427 END
40428
40429*$ CREATE PHO_SASGAM.FOR
40430*COPY PHO_SASGAM
40431CDECK ID>, PHO_SASGAM
40432C***********************************************************************
40433C...SaSgam version 2 - parton distributions of the photon
40434C...by Gerhard A. Schuler and Torbjorn Sjostrand
40435C...For further information see Z. Phys. C68 (1995) 607
40436C...and Phys. Lett. B376 (1996) 193.
40437
40438C...18 January 1996: original code.
40439C...22 July 1996: calculation of BETA moved in SASBEH.
40440
40441C!!!Note that one further call parameter - IP2 - has been added
40442C!!!to the SASGAM argument list compared with version 1.
40443
40444C...The user should only need to call the SASGAM routine,
40445C...which in turn calls the auxiliary routines SASVMD, SASANO,
40446C...SASBEH and SASDIR. The package is self-contained.
40447
40448C...One particular aspect of these parametrizations is that F2 for
40449C...the photon is not obtained just as the charge-squared-weighted
40450C...sum of quark distributions, but differ in the treatment of
40451C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40452C...the kinematics range of heavy-flavour production, but the same
40453C...kinematics is not relevant e.g. for jet production) and, for the
40454C...'MSbar' fits, in the addition of a Cgamma term related to the
40455C...separation of direct processes. Schematically:
40456C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40457C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40458C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40459C...The J/psi and Upsilon states have not been included in the VMD sum,
40460C...but low c and b masses in the other components should compensate
40461C...for this in a duality sense.
40462
40463C...The calling sequence is the following:
40464C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40465C...with the following declaration statement:
40466C DIMENSION XPDFGM(-6:6)
40467C...and, optionally, further information in:
40468C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40469C &XPDIR(-6:6)
40470C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40471C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40472C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40473C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40474C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40475C X : x value.
40476C Q2 : Q2 value.
40477C P2 : P2 value; should be = 0. for an on-shell photon.
40478C IP2 : scheme used to evaluate off-shell anomalous component.
40479C = 0 : recommended default, see = 7.
40480C = 1 : dipole dampening by integration; very time-consuming.
40481C = 2 : P_0^2 = max( Q_0^2, P^2 )
40482C = 3 : P_0^2 = Q_0^2 + P^2.
40483C = 4 : P_{eff} that preserves momentum sum.
40484C = 5 : P_{int} that preserves momentum and average
40485C evolution range.
40486C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40487C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40488C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40489C XPFDGM : x times parton distribution functions of the photon,
40490C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40491C 6 = t (always empty!), - for antiquarks (result is same).
40492C...The breakdown by component is stored in the commonblock SASCOM,
40493C with elements as above.
40494C XPVMD : rho, omega, phi VMD part only of output.
40495C XPANL : d, u, s anomalous part only of output.
40496C XPANH : c, b anomalous part only of output.
40497C XPBEH : c, b Bethe-Heitler part only of output.
40498C XPDIR : Cgamma (direct contribution) part only of output.
40499C...The above arrays do not distinguish valence and sea contributions,
40500C...although this information is available internally. The additional
40501C...commonblock SASVAL provides the valence part only of the above
40502C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40503C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40504C...and therefore not given doubly. VXPDGM gives the sum of valence
40505C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40506C...and so on, gives the sea part only.
40507C***********************************************************************
40508
40509 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40510C...Purpose: to construct the F2 and parton distributions of the photon
40511C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40512C...For F2, c and b are included by the Bethe-Heitler formula;
40513C...in the 'MSbar' scheme additionally a Cgamma term is added.
40514 SAVE
40515 DIMENSION XPDFGM(-6:6)
40516
40517C input/output channels
40518 INTEGER LI,LO
40519 COMMON /POINOU/ LI,LO
40520
40521 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40522 &XPDIR(-6:6)
40523 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
454792a9 40524CPH SAVE /SASCOM/,/SASVAL/
9aaba0d6 40525
40526C...Temporary array.
40527 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40528C...Charm and bottom masses (low to compensate for J/psi etc.).
40529 DATA PMC/1.3/, PMB/4.6/
40530C...alpha_em and alpha_em/(2*pi).
40531 DATA AEM/0.007297/, AEM2PI/0.0011614/
40532C...Lambda value for 4 flavours.
40533 DATA ALAM/0.20/
40534C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40535 DATA FRACU/0.8/
40536C...VMD couplings f_V**2/(4*pi).
40537 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40538C...Masses for rho (=omega) and phi.
40539 DATA PMRHO/0.770/, PMPHI/1.020/
40540C...Number of points in integration for IP2=1.
40541 DATA NSTEP/100/
40542
40543C...Reset output.
40544 F2GM=0.
40545 DO 100 KFL=-6,6
40546 XPDFGM(KFL)=0.
40547 XPVMD(KFL)=0.
40548 XPANL(KFL)=0.
40549 XPANH(KFL)=0.
40550 XPBEH(KFL)=0.
40551 XPDIR(KFL)=0.
40552 VXPVMD(KFL)=0.
40553 VXPANL(KFL)=0.
40554 VXPANH(KFL)=0.
40555 VXPDGM(KFL)=0.
40556 100 CONTINUE
40557
40558C...Check that input sensible.
40559 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40560 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40561 WRITE(LO,*) ' ISET = ',ISET
40562 STOP
40563 ENDIF
40564 IF(X.LE.0..OR.X.GT.1.) THEN
40565 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40566 WRITE(LO,*) ' X = ',X
40567 STOP
40568 ENDIF
40569
40570C...Set Q0 cut-off parameter as function of set used.
40571 IF(ISET.LE.2) THEN
40572 Q0=0.6
40573 ELSE
40574 Q0=2.
40575 ENDIF
40576 Q02=Q0**2
40577
40578C...Scale choice for off-shell photon; common factors.
40579 Q2A=Q2
40580 FACNOR=1.
40581 IF(IP2.EQ.1) THEN
40582 P2MX=P2+Q02
40583 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40584 FACNOR=LOG(Q2/Q02)/NSTEP
40585 ELSEIF(IP2.EQ.2) THEN
40586 P2MX=MAX(P2,Q02)
40587 ELSEIF(IP2.EQ.3) THEN
40588 P2MX=P2+Q02
40589 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40590 ELSEIF(IP2.EQ.4) THEN
40591 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40592 & ((Q2+P2)*(Q02+P2)))
40593 ELSEIF(IP2.EQ.5) THEN
40594 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40595 & ((Q2+P2)*(Q02+P2)))
40596 P2MX=Q0*SQRT(P2MXA)
40597 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40598 ELSEIF(IP2.EQ.6) THEN
40599 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40600 & ((Q2+P2)*(Q02+P2)))
40601 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40602 ELSE
40603 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40604 & ((Q2+P2)*(Q02+P2)))
40605 P2MX=Q0*SQRT(P2MXA)
40606 P2MXB=P2MX
40607 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40608 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40609 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40610 ENDIF
40611
40612C...Call VMD parametrization for d quark and use to give rho, omega,
40613C...phi. Note dipole dampening for off-shell photon.
40614 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40615 XFVAL=VXPGA(1)
40616 XPGA(1)=XPGA(2)
40617 XPGA(-1)=XPGA(-2)
40618 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40619 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40620 DO 110 KFL=-5,5
40621 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40622 110 CONTINUE
40623 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40624 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40625 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40626 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40627 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40628 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40629 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40630 VXPVMD(2)=FRACU*FACUD*XFVAL
40631 VXPVMD(3)=FACS*XFVAL
40632 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40633 VXPVMD(-2)=FRACU*FACUD*XFVAL
40634 VXPVMD(-3)=FACS*XFVAL
40635
40636 IF(IP2.NE.1) THEN
40637C...Anomalous parametrizations for different strategies
40638C...for off-shell photons; except full integration.
40639
40640C...Call anomalous parametrization for d + u + s.
40641 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40642 DO 120 KFL=-5,5
40643 XPANL(KFL)=FACNOR*XPGA(KFL)
40644 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40645 120 CONTINUE
40646
40647C...Call anomalous parametrization for c and b.
40648 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40649 DO 130 KFL=-5,5
40650 XPANH(KFL)=FACNOR*XPGA(KFL)
40651 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40652 130 CONTINUE
40653 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40654 DO 140 KFL=-5,5
40655 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40656 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40657 140 CONTINUE
40658
40659 ELSE
40660C...Special option: loop over flavours and integrate over k2.
40661 DO 170 KF=1,5
40662 DO 160 ISTEP=1,NSTEP
40663 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40664 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40665 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40666 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40667 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40668 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40669 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40670 DO 150 KFL=-5,5
40671 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40672 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40673 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40674 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40675 150 CONTINUE
40676 160 CONTINUE
40677 170 CONTINUE
40678 ENDIF
40679
40680C...Call Bethe-Heitler term expression for charm and bottom.
40681 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40682 XPBEH(4)=XPBH
40683 XPBEH(-4)=XPBH
40684 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40685 XPBEH(5)=XPBH
40686 XPBEH(-5)=XPBH
40687
40688C...For MSbar subtraction call C^gamma term expression for d, u, s.
40689 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40690 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40691 DO 180 KFL=-5,5
40692 XPDIR(KFL)=XPGA(KFL)
40693 180 CONTINUE
40694 ENDIF
40695
40696C...Store result in output array.
40697 DO 190 KFL=-5,5
40698 CHSQ=1./9.
40699 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40700 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40701 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40702 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40703 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40704 190 CONTINUE
40705
40706 RETURN
40707 END
40708
40709C*********************************************************************
40710
40711*$ CREATE PHO_SASVMD.FOR
40712*COPY PHO_SASVMD
40713CDECK ID>, PHO_SASVMD
40714 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40715C...Purpose: to evaluate the VMD parton distributions of a photon,
40716C...evolved homogeneously from an initial scale P2 to Q2.
40717C...Does not include dipole suppression factor.
40718C...ISET is parton distribution set, see above;
40719C...additionally ISET=0 is used for the evolution of an anomalous photon
40720C...which branched at a scale P2 and then evolved homogeneously to Q2.
40721C...ALAM is the 4-flavour Lambda, which is automatically converted
40722C...to 3- and 5-flavour equivalents as needed.
40723 SAVE
40724 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40725
40726C input/output channels
40727 INTEGER LI,LO
40728 COMMON /POINOU/ LI,LO
40729
40730 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40731
40732C...Reset output.
40733 DO 100 KFL=-6,6
40734 XPGA(KFL)=0.
40735 VXPGA(KFL)=0.
40736 100 CONTINUE
40737 KFA=IABS(KF)
40738
40739C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40740 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40741 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40742 P2EFF=MAX(P2,1.2*ALAM3**2)
40743 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40744 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40745 Q2EFF=MAX(Q2,P2EFF)
40746
40747C...Find number of flavours at lower and upper scale.
40748 NFP=4
40749 IF(P2EFF.LT.PMC**2) NFP=3
40750 IF(P2EFF.GT.PMB**2) NFP=5
40751 NFQ=4
40752 IF(Q2EFF.LT.PMC**2) NFQ=3
40753 IF(Q2EFF.GT.PMB**2) NFQ=5
40754
40755C...Find s as sum of 3-, 4- and 5-flavour parts.
40756 S=0.
40757 IF(NFP.EQ.3) THEN
40758 Q2DIV=PMC**2
40759 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40760 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40761 ENDIF
40762 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40763 P2DIV=P2EFF
40764 IF(NFP.EQ.3) P2DIV=PMC**2
40765 Q2DIV=Q2EFF
40766 IF(NFQ.EQ.5) Q2DIV=PMB**2
40767 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40768 ENDIF
40769 IF(NFQ.EQ.5) THEN
40770 P2DIV=PMB**2
40771 IF(NFP.EQ.5) P2DIV=P2EFF
40772 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40773 ENDIF
40774
40775C...Calculate frequent combinations of x and s.
40776 X1=1.-X
40777 XL=-LOG(X)
40778 S2=S**2
40779 S3=S**3
40780 S4=S**4
40781
40782C...Evaluate homogeneous anomalous parton distributions below or
40783C...above threshold.
40784 IF(ISET.EQ.0) THEN
40785 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40786 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40787 XVAL = X * 1.5 * (X**2+X1**2)
40788 XGLU = 0.
40789 XSEA = 0.
40790 ELSE
40791 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40792 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40793 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40794 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40795 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40796 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40797 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40798 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40799 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40800 & (2.*X-1.)*X*XL**2)
40801 ENDIF
40802
40803C...Evaluate set 1D parton distributions below or above threshold.
40804 ELSEIF(ISET.EQ.1) THEN
40805 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40806 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40807 XVAL = 1.294 * X**0.80 * X1**0.76
40808 XGLU = 1.273 * X**0.40 * X1**1.76
40809 XSEA = 0.100 * X1**3.76
40810 ELSE
40811 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40812 & X1**(0.76+0.667*S) * XL**(2.*S)
40813 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40814 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40815 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40816 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40817 & X**(-7.32*S2/(1.+10.3*S2)) *
40818 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40819 XSEA0 = 0.100 * X1**3.76
40820 ENDIF
40821
40822C...Evaluate set 1M parton distributions below or above threshold.
40823 ELSEIF(ISET.EQ.2) THEN
40824 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40825 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40826 XVAL = 0.8477 * X**0.51 * X1**1.37
40827 XGLU = 3.42 * X**0.255 * X1**2.37
40828 XSEA = 0.
40829 ELSE
40830 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40831 & * X1**1.37 * XL**(2.667*S)
40832 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40833 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40834 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40835 & X1**(2.37+3.*S)
40836 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40837 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40838 & XL**(2.8*S)
40839 XSEA0 = 0.
40840 ENDIF
40841
40842C...Evaluate set 2D parton distributions below or above threshold.
40843 ELSEIF(ISET.EQ.3) THEN
40844 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40845 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40846 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40847 XGLU = 1.925 * X1**2
40848 XSEA = 0.242 * X1**4
40849 ELSE
40850 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40851 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40852 & (0.76+0.4*S) * X * X1**(2.667*S)
40853 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40854 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40855 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40856 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40857 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40858 XSEA0 = 0.242 * X1**4
40859 ENDIF
40860
40861C...Evaluate set 2M parton distributions below or above threshold.
40862 ELSEIF(ISET.EQ.4) THEN
40863 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40864 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40865 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40866 XGLU = 1.808 * X1**2
40867 XSEA = 0.209 * X1**4
40868 ELSE
40869 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40870 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40871 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40872 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40873 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40874 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40875 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40876 & XL**(10.9*S/(1.+2.5*S))
40877 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40878 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40879 & X1**(4.+S) * XL**(0.45*S)
40880 XSEA0 = 0.209 * X1**4
40881 ENDIF
40882 ENDIF
40883
40884C...Threshold factors for c and b sea.
40885 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40886 XCHM=0.
40887 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40888 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40889 IF(ISET.EQ.0) THEN
40890 XCHM=XSEA*(1.-(SCH/SLL)**2)
40891 ELSE
40892 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40893 ENDIF
40894 ENDIF
40895 XBOT=0.
40896 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40897 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40898 IF(ISET.EQ.0) THEN
40899 XBOT=XSEA*(1.-(SBT/SLL)**2)
40900 ELSE
40901 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40902 ENDIF
40903 ENDIF
40904
40905C...Fill parton distributions.
40906 XPGA(0)=XGLU
40907 XPGA(1)=XSEA
40908 XPGA(2)=XSEA
40909 XPGA(3)=XSEA
40910 XPGA(4)=XCHM
40911 XPGA(5)=XBOT
40912 XPGA(KFA)=XPGA(KFA)+XVAL
40913 DO 110 KFL=1,5
40914 XPGA(-KFL)=XPGA(KFL)
40915 110 CONTINUE
40916 VXPGA(KFA)=XVAL
40917 VXPGA(-KFA)=XVAL
40918
40919 RETURN
40920 END
40921
40922C*********************************************************************
40923
40924*$ CREATE PHO_SASANO.FOR
40925*COPY PHO_SASANO
40926CDECK ID>, PHO_SASANO
40927 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40928C...Purpose: to evaluate the parton distributions of the anomalous
40929C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40930C...to Q2.
40931C...KF=0 gives the sum over (up to) 5 flavours,
40932C...KF<0 limits to flavours up to abs(KF),
40933C...KF>0 is for flavour KF only.
40934C...ALAM is the 4-flavour Lambda, which is automatically converted
40935C...to 3- and 5-flavour equivalents as needed.
40936 SAVE
40937
40938C input/output channels
40939 INTEGER LI,LO
40940 COMMON /POINOU/ LI,LO
40941
40942 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40943 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40944
40945C...Reset output.
40946 DO 100 KFL=-6,6
40947 XPGA(KFL)=0.
40948 VXPGA(KFL)=0.
40949 100 CONTINUE
40950 IF(Q2.LE.P2) RETURN
40951 KFA=IABS(KF)
40952
40953C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40954 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40955 ALAMSQ(4)=ALAM**2
40956 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40957 P2EFF=MAX(P2,1.2*ALAMSQ(3))
40958 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40959 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40960 Q2EFF=MAX(Q2,P2EFF)
40961 XL=-LOG(X)
40962
40963C...Find number of flavours at lower and upper scale.
40964 NFP=4
40965 IF(P2EFF.LT.PMC**2) NFP=3
40966 IF(P2EFF.GT.PMB**2) NFP=5
40967 NFQ=4
40968 IF(Q2EFF.LT.PMC**2) NFQ=3
40969 IF(Q2EFF.GT.PMB**2) NFQ=5
40970
40971C...Define range of flavour loop.
40972 IF(KF.EQ.0) THEN
40973 KFLMN=1
40974 KFLMX=5
40975 ELSEIF(KF.LT.0) THEN
40976 KFLMN=1
40977 KFLMX=KFA
40978 ELSE
40979 KFLMN=KFA
40980 KFLMX=KFA
40981 ENDIF
40982
40983C...Loop over flavours the photon can branch into.
40984 DO 110 KFL=KFLMN,KFLMX
40985
40986C...Light flavours: calculate t range and (approximate) s range.
40987 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40988 TDIFF=LOG(Q2EFF/P2EFF)
40989 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40990 & LOG(P2EFF/ALAMSQ(NFQ)))
40991 IF(NFQ.GT.NFP) THEN
40992 Q2DIV=PMB**2
40993 IF(NFQ.EQ.4) Q2DIV=PMC**2
40994 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40995 & LOG(P2EFF/ALAMSQ(NFQ)))
40996 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40997 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40998 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40999 ENDIF
41000 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41001 Q2DIV=PMC**2
41002 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41003 & LOG(P2EFF/ALAMSQ(4)))
41004 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41005 & LOG(P2EFF/ALAMSQ(3)))
41006 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41007 ENDIF
41008
41009C...u and s quark do not need a separate treatment when d has been done.
41010 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41011
41012C...Charm: as above, but only include range above c threshold.
41013 ELSEIF(KFL.EQ.4) THEN
41014 IF(Q2.LE.PMC**2) GOTO 110
41015 P2EFF=MAX(P2EFF,PMC**2)
41016 Q2EFF=MAX(Q2EFF,P2EFF)
41017 TDIFF=LOG(Q2EFF/P2EFF)
41018 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41019 & LOG(P2EFF/ALAMSQ(NFQ)))
41020 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41021 Q2DIV=PMB**2
41022 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41023 & LOG(P2EFF/ALAMSQ(NFQ)))
41024 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41025 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41026 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41027 ENDIF
41028
41029C...Bottom: as above, but only include range above b threshold.
41030 ELSEIF(KFL.EQ.5) THEN
41031 IF(Q2.LE.PMB**2) GOTO 110
41032 P2EFF=MAX(P2EFF,PMB**2)
41033 Q2EFF=MAX(Q2,P2EFF)
41034 TDIFF=LOG(Q2EFF/P2EFF)
41035 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41036 & LOG(P2EFF/ALAMSQ(NFQ)))
41037 ENDIF
41038
41039C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41040 CHSQ=1./9.
41041 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41042 FAC=AEM2PI*2.*CHSQ*TDIFF
41043
41044C...Evaluate parton distributions (normalized to unit momentum sum).
41045 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41046 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41047 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41048 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41049 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41050 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41051 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41052 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41053 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41054 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41055 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41056 & (2.*X-1.)*X*XL**2)
41057
41058C...Threshold factors for c and b sea.
41059 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41060 XCHM=0.
41061 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41062 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41063 XCHM=XSEA*(1.-(SCH/SLL)**3)
41064 ENDIF
41065 XBOT=0.
41066 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41067 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41068 XBOT=XSEA*(1.-(SBT/SLL)**3)
41069 ENDIF
41070 ENDIF
41071
41072C...Add contribution of each valence flavour.
41073 XPGA(0)=XPGA(0)+FAC*XGLU
41074 XPGA(1)=XPGA(1)+FAC*XSEA
41075 XPGA(2)=XPGA(2)+FAC*XSEA
41076 XPGA(3)=XPGA(3)+FAC*XSEA
41077 XPGA(4)=XPGA(4)+FAC*XCHM
41078 XPGA(5)=XPGA(5)+FAC*XBOT
41079 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41080 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41081 110 CONTINUE
41082 DO 120 KFL=1,5
41083 XPGA(-KFL)=XPGA(KFL)
41084 VXPGA(-KFL)=VXPGA(KFL)
41085 120 CONTINUE
41086
41087 END
41088
41089C*********************************************************************
41090
41091*$ CREATE PHO_SASBEH.FOR
41092*COPY PHO_SASBEH
41093CDECK ID>, PHO_SASBEH
41094 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41095C...Purpose: to evaluate the Bethe-Heitler cross section for
41096C...heavy flavour production.
41097 SAVE
41098 DATA AEM2PI/0.0011614/
41099
41100C...Reset output.
41101 XPBH=0.
41102 SIGBH=0.
41103
41104C...Check kinematics limits.
41105 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41106 W2=Q2*(1.-X)/X-P2
41107 BETA2=1.-4.*PM2/W2
41108 IF(BETA2.LT.1E-10) RETURN
41109 BETA=SQRT(BETA2)
41110 RMQ=4.*PM2/Q2
41111
41112C...Simple case: P2 = 0.
41113 IF(P2.LT.1E-4) THEN
41114 IF(BETA.LT.0.99) THEN
41115 XBL=LOG((1.+BETA)/(1.-BETA))
41116 ELSE
41117 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41118 ENDIF
41119 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41120 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41121
41122C...Complicated case: P2 > 0, based on approximation of
41123C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41124 ELSE
41125 RPQ=1.-4.*X**2*P2/Q2
41126 IF(RPQ.GT.1E-10) THEN
41127 RPBE=SQRT(RPQ*BETA2)
41128 IF(RPBE.LT.0.99) THEN
41129 XBL=LOG((1.+RPBE)/(1.-RPBE))
41130 XBI=2.*RPBE/(1.-RPBE**2)
41131 ELSE
41132 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41133 XBL=LOG((1.+RPBE)**2/RPBESN)
41134 XBI=2.*RPBE/RPBESN
41135 ENDIF
41136 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41137 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41138 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41139 ENDIF
41140 ENDIF
41141
41142C...Multiply by charge-squared etc. to get parton distribution.
41143 CHSQ=1./9.
41144 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41145 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41146
41147 END
41148
41149C*********************************************************************
41150
41151*$ CREATE PHO_SASDIR.FOR
41152*COPY PHO_SASDIR
41153CDECK ID>, PHO_SASDIR
41154 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41155C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41156C...as needed in MSbar parametrizations.
41157 SAVE
41158 DIMENSION XPGA(-6:6)
41159 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41160
41161C...Reset output.
41162 DO 100 KFL=-6,6
41163 XPGA(KFL)=0.
41164 100 CONTINUE
41165
41166C...Evaluate common x-dependent expression.
41167 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41168 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41169
41170C...d, u, s part by simple charge factor.
41171 XPGA(1)=(1./9.)*CGAM
41172 XPGA(2)=(4./9.)*CGAM
41173 XPGA(3)=(1./9.)*CGAM
41174
41175C...Also fill for antiquarks.
41176 DO 110 KF=1,5
41177 XPGA(-KF)=XPGA(KF)
41178 110 CONTINUE
41179
41180 END
41181
41182*$ CREATE PHO_PHGAL.FOR
41183*COPY PHO_PHGAL
41184CDECK ID>, PHO_PHGAL
41185 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41186C***********************************************************************
41187C
41188C photon parton densities with built-in momentum sum rule and
41189C Regge-based low-x behaviour
41190C
41191C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41192C e-Print Archive: hep-ph/9711355
41193C
41194C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41195C
41196C***********************************************************************
41197 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41198 SAVE
41199
41200 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41201 DOUBLE PRECISION
41202 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41203 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41204
41205 DIMENSION NA(NARG)
41206
41207 DATA ZEROD/0.D0/
41208
41209C...100 x values; in (D-4,.77) log spaced (78 points)
41210C... in (.78,.995) lineary spaced (22 points)
41211 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41212 DATA XT/
41213 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41214 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41215 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41216 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41217 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41218 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41219 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41220 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41221 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41222 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41223 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41224 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41225 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41226 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41227 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41228 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41229 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41230
41231C...place for DATA blocks
41232 DATA (XPV(I,1,0),I=1,100)/
41233 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41234 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41235 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41236 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41237 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41238 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41239 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41240 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41241 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41242 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41243 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41244 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41245 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41246 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41247 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41248 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41249 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41250 DATA (XPV(I,1,1),I=1,100)/
41251 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41252 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41253 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41254 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41255 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41256 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41257 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41258 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41259 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41260 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41261 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41262 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41263 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41264 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41265 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41266 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41267 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41268 DATA (XPV(I,1,2),I=1,100)/
41269 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41270 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41271 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41272 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41273 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41274 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41275 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41276 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41277 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41278 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41279 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41280 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41281 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41282 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41283 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41284 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41285 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41286 DATA (XPV(I,1,3),I=1,100)/
41287 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41288 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41289 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41290 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41291 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41292 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41293 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41294 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41295 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41296 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41297 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41298 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41299 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41300 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41301 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41302 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41303 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41304 DATA (XPV(I,1,4),I=1,100)/
41305 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41306 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41307 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41308 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41309 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41310 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41311 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41312 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41313 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41314 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41315 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41316 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41317 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41318 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41319 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41320 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41321 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41322 DATA (XPV(I,2,0),I=1,100)/
41323 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41324 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41325 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41326 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41327 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41328 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41329 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41330 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41331 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41332 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41333 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41334 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41335 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41336 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41337 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41338 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41339 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41340 DATA (XPV(I,2,1),I=1,100)/
41341 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41342 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41343 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41344 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41345 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41346 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41347 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41348 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41349 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41350 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41351 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41352 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41353 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41354 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41355 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41356 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41357 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41358 DATA (XPV(I,2,2),I=1,100)/
41359 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41360 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41361 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41362 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41363 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41364 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41365 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41366 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41367 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41368 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41369 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41370 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41371 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41372 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41373 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41374 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41375 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41376 DATA (XPV(I,2,3),I=1,100)/
41377 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41378 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41379 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41380 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41381 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41382 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41383 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41384 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41385 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41386 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41387 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41388 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41389 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41390 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41391 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41392 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41393 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41394 DATA (XPV(I,2,4),I=1,100)/
41395 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41396 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41397 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41398 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41399 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41400 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41401 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41402 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41403 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41404 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41405 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41406 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41407 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41408 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41409 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41410 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41411 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41412 DATA (XPV(I,3,0),I=1,100)/
41413 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41414 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41415 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41416 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41417 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41418 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41419 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41420 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41421 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41422 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41423 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41424 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41425 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41426 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41427 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41428 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41429 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41430 DATA (XPV(I,3,1),I=1,100)/
41431 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41432 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41433 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41434 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41435 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41436 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41437 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41438 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41439 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41440 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41441 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41442 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41443 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41444 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41445 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41446 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41447 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41448 DATA (XPV(I,3,2),I=1,100)/
41449 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41450 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41451 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41452 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41453 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41454 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41455 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41456 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41457 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41458 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41459 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41460 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41461 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41462 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41463 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41464 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41465 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41466 DATA (XPV(I,3,3),I=1,100)/
41467 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41468 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41469 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41470 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41471 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41472 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41473 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41474 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41475 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41476 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41477 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41478 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41479 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41480 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41481 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41482 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41483 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41484 DATA (XPV(I,3,4),I=1,100)/
41485 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41486 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41487 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41488 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41489 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41490 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41491 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41492 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41493 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41494 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41495 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41496 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41497 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41498 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41499 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41500 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41501 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41502 DATA (XPV(I,4,0),I=1,100)/
41503 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41504 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41505 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41506 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41507 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41508 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41509 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41510 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41511 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41512 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41513 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41514 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41515 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41516 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41517 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41518 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41519 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41520 DATA (XPV(I,4,1),I=1,100)/
41521 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41522 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41523 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41524 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41525 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41526 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41527 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41528 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41529 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41530 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41531 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41532 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41533 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41534 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41535 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41536 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41537 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41538 DATA (XPV(I,4,2),I=1,100)/
41539 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41540 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41541 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41542 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41543 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41544 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41545 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41546 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41547 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41548 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41549 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41550 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41551 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41552 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41553 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41554 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41555 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41556 DATA (XPV(I,4,3),I=1,100)/
41557 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41558 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41559 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41560 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41561 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41562 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41563 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41564 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41565 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41566 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41567 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41568 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41569 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41570 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41571 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41572 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41573 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41574 DATA (XPV(I,4,4),I=1,100)/
41575 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41576 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41577 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41578 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41579 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41580 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41581 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41582 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41583 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41584 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41585 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41586 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41587 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41588 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41589 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41590 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41591 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41592 DATA (XPV(I,5,0),I=1,100)/
41593 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41594 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41595 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41596 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41597 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41598 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41599 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41600 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41601 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41602 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41603 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41604 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41605 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41606 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41607 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41608 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41609 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41610 DATA (XPV(I,5,1),I=1,100)/
41611 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41612 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41613 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41614 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41615 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41616 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41617 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41618 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41619 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41620 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41621 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41622 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41623 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41624 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41625 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41626 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41627 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41628 DATA (XPV(I,5,2),I=1,100)/
41629 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41630 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41631 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41632 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41633 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41634 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41635 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41636 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41637 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41638 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41639 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41640 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41641 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41642 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41643 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41644 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41645 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41646 DATA (XPV(I,5,3),I=1,100)/
41647 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41648 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41649 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41650 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41651 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41652 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41653 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41654 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41655 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41656 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41657 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41658 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41659 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41660 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41661 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41662 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41663 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41664 DATA (XPV(I,5,4),I=1,100)/
41665 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41666 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41667 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41668 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41669 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41670 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41671 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41672 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41673 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41674 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41675 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41676 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41677 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41678 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41679 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41680 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41681 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41682 DATA (XPV(I,6,0),I=1,100)/
41683 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41684 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41685 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41686 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41687 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41688 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41689 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41690 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41691 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41692 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41693 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41694 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41695 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41696 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41697 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41698 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41699 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41700 DATA (XPV(I,6,1),I=1,100)/
41701 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41702 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41703 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41704 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41705 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41706 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41707 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41708 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41709 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41710 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41711 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41712 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41713 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41714 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41715 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41716 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41717 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41718 DATA (XPV(I,6,2),I=1,100)/
41719 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41720 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41721 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41722 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41723 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41724 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41725 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41726 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41727 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41728 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41729 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41730 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41731 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41732 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41733 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41734 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41735 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41736 DATA (XPV(I,6,3),I=1,100)/
41737 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41738 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41739 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41740 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41741 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41742 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41743 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41744 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41745 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41746 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41747 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41748 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41749 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41750 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41751 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41752 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41753 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41754 DATA (XPV(I,6,4),I=1,100)/
41755 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41756 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41757 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41758 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41759 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41760 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41761 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41762 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41763 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41764 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41765 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41766 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41767 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41768 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41769 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41770 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41771 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41772 DATA (XPV(I,7,0),I=1,100)/
41773 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41774 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41775 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41776 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41777 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41778 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41779 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41780 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41781 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41782 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41783 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41784 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41785 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41786 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41787 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41788 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41789 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41790 DATA (XPV(I,7,1),I=1,100)/
41791 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41792 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41793 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41794 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41795 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41796 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41797 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41798 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41799 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41800 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41801 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41802 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41803 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41804 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41805 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41806 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41807 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41808 DATA (XPV(I,7,2),I=1,100)/
41809 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41810 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41811 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41812 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41813 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41814 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41815 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41816 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41817 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41818 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41819 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41820 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41821 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41822 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41823 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41824 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41825 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41826 DATA (XPV(I,7,3),I=1,100)/
41827 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41828 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41829 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41830 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41831 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41832 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41833 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41834 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41835 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41836 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41837 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41838 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41839 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41840 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41841 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41842 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41843 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41844 DATA (XPV(I,7,4),I=1,100)/
41845 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41846 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41847 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41848 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41849 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41850 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41851 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41852 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41853 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41854 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41855 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41856 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41857 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41858 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41859 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41860 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41861 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41862
41863C..fetching pdfs
41864 DO 5 IP=-6,6
41865 XPDF(IP)=ZEROD
41866 5 CONTINUE
41867 DO 2 I=1,IX
41868 ENT(I)=LOG10(XT(I))
41869 2 CONTINUE
41870 NA(1)=IX
41871 NA(2)=IQ
41872 DO 3 I=1,IQ
41873 ENT(IX+I)=LOG10(Q2T(I))
41874 3 CONTINUE
41875 ARG(1)=LOG10(X)
41876 ARG(2)=LOG10(Q2)
41877C..various flavours (u-->2,d-->1)
41878 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41879 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41880 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41881 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41882 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41883 DO 21 JF=1,4
41884 XPDF(-JF)=XPDF(JF)
41885 21 CONTINUE
41886
41887 END
41888
41889*$ CREATE PHO_DBFINT.FOR
41890*COPY PHO_DBFINT
41891CDECK ID>, PHO_DBFINT
41892 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41893C***********************************************************************
41894C
41895C routine based on CERN library E104
41896C
41897C multi-dimensional interpolation routine, needed for PHOJET
41898C internal cross section tables and several PDF sets (GRV98 and AGL)
41899C
41900C changed to avoid recursive function calls (R.Engel, 09/98)
41901C
41902C***********************************************************************
41903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41904 SAVE
41905
41906 INTEGER NA(NARG), INDEX(32)
41907 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41908
41909 DATA ZEROD/0.D0/
41910 DATA ONED/1.D0/
41911
41912 DBFINT = ZEROD
41913 PHO_DBFINT = ZEROD
41914 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41915
41916 LMAX = 0
41917 ISTEP = 1
41918 KNOTS = 1
41919 INDEX(1) = 1
41920 WEIGHT(1) = ONED
41921 DO 100 N = 1, NARG
41922 X = ARG(N)
41923 NDIM = NA(N)
41924 LOCA = LMAX
41925 LMIN = LMAX + 1
41926 LMAX = LMAX + NDIM
41927 IF(NDIM .GT. 2) GOTO 10
41928 IF(NDIM .EQ. 1) GOTO 100
41929 H = X - ENT(LMIN)
41930 IF(H .EQ. ZEROD) GOTO 90
41931 ISHIFT = ISTEP
41932 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41933 ISHIFT = 0
41934 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41935 GOTO 30
41936 10 LOCB = LMAX + 1
41937 11 LOCC = (LOCA+LOCB) / 2
41938 IF(X-ENT(LOCC)) 12, 20, 13
41939 12 LOCB = LOCC
41940 GOTO 14
41941 13 LOCA = LOCC
41942 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41943 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41944 ISHIFT = (LOCA - LMIN) * ISTEP
41945 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41946 GOTO 30
41947 20 ISHIFT = (LOCC - LMIN) * ISTEP
41948 21 DO 22 K = 1, KNOTS
41949 INDEX(K) = INDEX(K) + ISHIFT
41950 22 CONTINUE
41951 GOTO 90
41952 30 DO 31 K = 1, KNOTS
41953 INDEX(K) = INDEX(K) + ISHIFT
41954 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41955 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41956 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41957 31 CONTINUE
41958 KNOTS = 2*KNOTS
41959 90 ISTEP = ISTEP * NDIM
41960 100 CONTINUE
41961 DO 200 K = 1, KNOTS
41962 I = INDEX(K)
41963 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
41964 200 CONTINUE
41965
41966 PHO_DBFINT = DBFINT
41967
41968 END
41969
41970*$ CREATE PHVAL.FOR
41971*COPY PHVAL
41972CDECK ID>, PHVAL
41973 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41974C**********************************************************************
41975C
41976C dummy subroutine, remove to link PHOLIB
41977C
41978C**********************************************************************
41979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41980 DIMENSION PD(-6:6)
41981 END