]> 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
Use fixed Ecut instead of pT-dependent
[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),
09b429a4 2499 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
9aaba0d6 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
09b429a4 11839 PARAMETER (NMXHEP=4000)
11840 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
11841 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
11842 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
11843
9aaba0d6 11844C model switches and parameters
11845 CHARACTER*8 MDLNA
11846 INTEGER ISWMDL,IPAMDL
11847 DOUBLE PRECISION PARMDL
11848 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11849C table of particle indices for recursive PHOJET calls
11850 INTEGER MAXIPX
11851 PARAMETER ( MAXIPX = 100 )
11852 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11853 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11854 & IPOIX1,IPOIX2,IPOIX3
11855C general process information
11856 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11857 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11858C global event kinematics and particle IDs
11859 INTEGER IFPAP,IFPAB
11860 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11861 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11862C cross sections
11863 INTEGER IPFIL,IFAFIL,IFBFIL
11864 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11865 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11866 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11867 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11868 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11869 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11870 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11871 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11872 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11873 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11874 & IPFIL,IFAFIL,IFBFIL
11875C event weights and generated cross section
11876 INTEGER IPOWGC,ISWCUT,IVWGHT
11877 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11878 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11879 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11880C internal rejection counters
11881 INTEGER NMXJ
11882 PARAMETER (NMXJ=60)
11883 CHARACTER*10 REJTIT
11884 INTEGER IFAIL
11885 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11886
11887 IREJ = 0
11888C clear event statistics
11889 KSPOM = 0
11890 KHPOM = 0
11891 KSREG = 0
11892 KHDIR = 0
11893 KSTRG = 0
11894 KHTRG = 0
11895 KSLOO = 0
11896 KHLOO = 0
11897 KHARD = 0
11898 KSOFT = 0
11899 KSDPO = 0
11900 KHDPO = 0
11901
11902C-------------------------------------------------------------------
11903C nondiffractive resolved processes
11904
11905 IF(IPROC.EQ.1) THEN
11906C sample number of interactions
11907 555 CONTINUE
11908 IINT = 0
11909 IP = 1
11910C generate only hard events
11911 IF(ISWMDL(2).EQ.0) THEN
11912 MHPOM = 1
11913 MSPOM = 0
11914 MSREG = 0
11915 MHDIR = 0
11916 HSWGHT(1) = 1.D0
11917 ELSE
11918C minimum bias events
11919 IPOWGC(1) = 0
11920 10 CONTINUE
11921 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11922 IPOWGC(1) = IPOWGC(1)+1
11923 MINT = 0
11924 MHDIR = 0
11925 MSTRG = 0
11926 MSLOO = 0
11927C
11928C resolved soft processes: pomeron and reggeon
11929 MSPOM = IINT
11930 MSREG = JINT
11931C resolved hard process: hard pomeron
11932 MHPOM = KINT
11933C resolved absorptive corrections
11934 MPTRI = 0
11935 MPLOO = 0
11936C restrictions given by user
11937 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11938 IF(MSREG.LT.ISWCUT(2)) GOTO 10
11939 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11940 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11941C ----------------------------
11942 IF(ISWMDL(15).EQ.0) THEN
11943 MHPOM = 0
11944 IF(MSREG.GT.0) THEN
11945 MSPOM = 0
11946 MSREG = 1
11947 ELSE
11948 MSPOM = 1
11949 MSREG = 0
11950 ENDIF
11951 ELSE IF(ISWMDL(15).EQ.1) THEN
11952 IF(MHPOM.GT.0) THEN
11953 MHPOM = 1
11954 MSPOM = 0
11955 MSREG = 0
11956 ELSE IF(MSPOM.GT.0) THEN
11957 MSPOM = 1
11958 MSREG = 0
11959 ELSE
11960 MSREG = 1
11961 ENDIF
11962 ELSE IF(ISWMDL(15).EQ.2) THEN
11963 MHPOM = MIN(1,MHPOM)
11964 ELSE IF(ISWMDL(15).EQ.3) THEN
11965 MSPOM = MIN(1,MSPOM)
11966 ENDIF
11967 ENDIF
11968C ----------------------------
11969
11970C statistics
11971 ISPS = ISPS+MSPOM
11972 IHPS = IHPS+MHPOM
11973 ISRS = ISRS+MSREG
11974 ISTS = ISTS+MSTRG
11975 ISLS = ISLS+MSLOO
11976
11977 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11978 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11979 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11980
11981 ITRY2 = 0
11982 50 CONTINUE
11983 ITRY2 = ITRY2+1
11984 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11985 KSPOM = MSPOM
11986 KSREG = MSREG
11987 KHPOM = MHPOM
11988 KHDIR = MHDIR
11989 KSTRG = MPTRI
11990 KSLOO = MPLOO
11991
11992 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11993 IF(IREJ.NE.0) THEN
11994 IF(IREJ.EQ.50) RETURN
11995 IF(IDEB(3).GE.2) THEN
11996 WRITE(LO,'(/1X,A,I5)')
11997 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11998 CALL PHO_PREVNT(-1)
11999 ENDIF
12000 RETURN
12001 ENDIF
12002 IF(MHPOM.GT.0) THEN
12003 IDNODF = 3
12004 ELSE IF(MSPOM.GT.0) THEN
12005 IDNODF = 2
12006 ELSE
12007 IDNODF = 1
12008 ENDIF
12009C check of quantum numbers of parton configurations
12010 IF(IDEB(3).GE.0) THEN
12011 CALL PHO_CHECK(1,IREJ)
12012 IF(IREJ.NE.0) GOTO 50
12013 ENDIF
12014C sample strings to prepare fragmentation
12015 CALL PHO_STRING(1,IREJ)
12016 IF(IREJ.NE.0) THEN
12017 IF(IREJ.EQ.50) RETURN
12018 IFAIL(30) = IFAIL(30)+1
12019 IF(IDEB(3).GE.2) THEN
12020 WRITE(LO,'(/1X,A,I5)')
12021 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12022 CALL PHO_PREVNT(-1)
12023 ENDIF
12024 IF(ITRY2.LT.20) GOTO 50
12025 IF(IDEB(3).GE.1) THEN
12026 WRITE(LO,'(/1X,A,I5)')
12027 & 'PHO_PARTON: rejection',ITRY2
12028 CALL PHO_PREVNT(-1)
12029 ENDIF
12030 RETURN
12031 ENDIF
12032
12033C statistics
12034 ISPA = ISPA+KSPOM
12035 IHPA = IHPA+KHPOM
12036 ISRA = ISRA+KSREG
12037 ISTA = ISTA+KSTRG
12038 ISLA = ISLA+KSLOO
12039
12040C-------------------------------------------------------------------
12041C elastic scattering / quasi-elastic rho/omega/phi production
12042
12043 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12044 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12045 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12046
12047C DPMJET call with special projectile / target: transform into CMS
12048 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12049 & CALL PHO_DFWRAP(1,JM1,JM2)
12050
12051 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12052
12053 IF(IREJ.NE.0) THEN
12054C DPMJET call with special projectile / target: clean up
12055 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12056 & CALL PHO_DFWRAP(-2,JM1,JM2)
12057 IF(IDEB(3).GE.2) THEN
12058 WRITE(LO,'(/1X,A,I5)')
12059 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12060 CALL PHO_PREVNT(-1)
12061 ENDIF
12062 RETURN
12063 ENDIF
12064
12065C DPMJET call with special projectile / target: transform back
12066 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12067 & CALL PHO_DFWRAP(2,JM1,JM2)
12068
12069C prepare possible decays
12070 CALL PHO_STRING(1,IREJ)
12071 IF(IREJ.NE.0) THEN
12072 IF(IREJ.EQ.50) RETURN
12073 IFAIL(30) = IFAIL(30)+1
12074 RETURN
12075 ENDIF
12076
12077C---------------------------------------------------------------------
12078C double Pomeron scattering
12079
12080 ELSE IF(IPROC.EQ.4) THEN
12081 MSOFT = 0
12082 MHARD = 0
12083 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12084 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12085 IDPS = IDPS+1
12086 ITRY2 = 0
12087 60 CONTINUE
12088 ITRY2 = ITRY2+1
12089 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12090C
12091 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12092 IF(IREJ.NE.0) THEN
12093 IF(IDEB(3).GE.2) THEN
12094 WRITE(LO,'(/1X,A,I5)')
12095 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12096 CALL PHO_PREVNT(-1)
12097 ENDIF
12098 RETURN
12099 ENDIF
12100C check of quantum numbers of parton configurations
12101 IF(IDEB(3).GE.0) THEN
12102 CALL PHO_CHECK(1,IREJ)
12103 IF(IREJ.NE.0) GOTO 60
12104 ENDIF
12105C sample strings to prepare fragmentation
12106 CALL PHO_STRING(1,IREJ)
12107 IF(IREJ.NE.0) THEN
12108 IF(IREJ.EQ.50) RETURN
12109 IFAIL(30) = IFAIL(30)+1
12110 IF(IDEB(3).GE.2) THEN
12111 WRITE(LO,'(/1X,A,I5)')
12112 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12113 CALL PHO_PREVNT(-1)
12114 ENDIF
12115 IF(ITRY2.LT.10) GOTO 60
12116 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12117 CALL PHO_PREVNT(-1)
12118 RETURN
12119 ENDIF
12120 IDPA = IDPA+1
12121
12122C-----------------------------------------------------------------------
12123C single / double diffraction dissociation
12124
12125 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12126 MSOFT = 0
12127 MHARD = 0
12128 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12129 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12130 IF(IPROC.EQ.5) ID1S = ID1S+1
12131 IF(IPROC.EQ.6) ID2S = ID2S+1
12132 IF(IPROC.EQ.7) ID3S = ID3S+1
12133 ITRY2 = 0
12134 70 CONTINUE
12135 ITRY2 = ITRY2+1
12136 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12137 IPAR1 = 1
12138 IPAR2 = 1
12139 IF(IPROC.EQ.5) IPAR2 = 0
12140 IF(IPROC.EQ.6) IPAR1 = 0
12141C calculate rapidity gap survival probability
12142 SPROB = 1.D0
12143 IF(ECM.GT.10.D0) THEN
12144 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12145 IF(SIGTR1(1).LT.1.D-10) THEN
12146 SPROB = 1.D0
12147 ELSE
12148 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12149 ENDIF
12150 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12151 IF(SIGTR2(1).LT.1.D-10) THEN
12152 SPROB = 1.D0
12153 ELSE
12154 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12155 ENDIF
12156 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12157 IF(SIGLOO.LT.1.D-10) THEN
12158 SPROB = 1.D0
12159 ELSE
12160 SPROB = SIGHDD/SIGLOO
12161 ENDIF
12162 ENDIF
12163 ENDIF
12164**sr
12165* temporary patch, r.e. 8.6.99
12166 SPROB = 1.D0
12167**
12168
12169C DPMJET call with special projectile / target: transform into CMS
12170 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12171 & CALL PHO_DFWRAP(1,JM1,JM2)
12172
12173 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12174
12175 IF(IREJ.NE.0) THEN
12176C DPMJET call with special projectile / target: clean up
12177 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12178 & CALL PHO_DFWRAP(-2,JM1,JM2)
12179 IF(IDEB(3).GE.2) THEN
12180 WRITE(LO,'(/1X,A,I5)')
12181 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12182 CALL PHO_PREVNT(-1)
12183 ENDIF
12184 RETURN
12185 ENDIF
12186
12187C DPMJET call with special projectile / target: transform back
12188 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12189 & CALL PHO_DFWRAP(2,JM1,JM2)
12190
12191C check of quantum numbers of parton configurations
12192 IF(IDEB(3).GE.0) THEN
12193 CALL PHO_CHECK(1,IREJ)
12194 IF(IREJ.NE.0) GOTO 70
12195 ENDIF
12196C sample strings to prepare fragmentation
12197 CALL PHO_STRING(1,IREJ)
12198 IF(IREJ.NE.0) THEN
12199 IF(IREJ.EQ.50) RETURN
12200 IFAIL(30) = IFAIL(30)+1
12201 IF(IDEB(3).GE.2) THEN
12202 WRITE(LO,'(/1X,A,I5)')
12203 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12204 CALL PHO_PREVNT(-1)
12205 ENDIF
12206 IF(ITRY2.LT.10) GOTO 70
12207 WRITE(LO,'(/1X,A,I5)')
12208 & 'PHO_PARTON: rejection',ITRY2
12209 CALL PHO_PREVNT(-1)
12210 RETURN
12211 ENDIF
09b429a4 12212 IF(IPROC.EQ.5) THEN
12213 ID1A = ID1A+1
12214 NSD1 = NSD1 +1
12215 ENDIF
12216 IF(IPROC.EQ.6) THEN
12217 ID2A = ID2A+1
12218 NSD2 = NSD2 + 1
12219 ENDIF
12220 IF(IPROC.EQ.7) THEN
12221 ID3A = ID3A+1
12222 NDD = NDD + 1
12223 ENDIF
9aaba0d6 12224C-----------------------------------------------------------------------
12225C single / double direct processes
12226
12227 ELSE IF(IPROC.EQ.8) THEN
12228 MSREG = 0
12229 MSPOM = 0
12230 MHPOM = 0
12231 MHDIR = 1
12232 IF(IDEB(3).GE.5) THEN
12233 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12234 ENDIF
12235 IDIS = IDIS+MHDIR
12236 ITRY2 = 0
12237 80 CONTINUE
12238 ITRY2 = ITRY2+1
12239 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12240 KSPOM = MSPOM
12241 KSREG = MSREG
12242 KHPOM = MHPOM
12243 KHDIR = 4
12244
12245 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12246 IF(IREJ.NE.0) THEN
12247 IF(IREJ.EQ.50) RETURN
12248 IF(IDEB(3).GE.2) THEN
12249 WRITE(LO,'(/1X,A,I5)')
12250 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12251 CALL PHO_PREVNT(-1)
12252 ENDIF
12253 RETURN
12254 ENDIF
12255 IDNODF = 4
12256C check of quantum numbers of parton configurations
12257 IF(IDEB(3).GE.0) THEN
12258 CALL PHO_CHECK(1,IREJ)
12259 IF(IREJ.NE.0) GOTO 80
12260 ENDIF
12261C sample strings to prepare fragmentation
12262 CALL PHO_STRING(1,IREJ)
12263 IF(IREJ.NE.0) THEN
12264 IF(IREJ.EQ.50) RETURN
12265 IFAIL(30) = IFAIL(30)+1
12266 IF(IDEB(3).GE.2) THEN
12267 WRITE(LO,'(/1X,A,I5)')
12268 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12269 CALL PHO_PREVNT(-1)
12270 ENDIF
12271 IF(ITRY2.LT.10) GOTO 80
12272 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12273 CALL PHO_PREVNT(-1)
12274 RETURN
12275 ENDIF
09b429a4 12276 IF(IPROC.EQ.5) THEN
12277 ID1A = ID1A+1
12278 NSD1 = NSD1 +1
12279 ENDIF
12280 IF(IPROC.EQ.6) THEN
12281 ID2A = ID2A+1
12282 NSD2 = NSD2 + 1
12283 ENDIF
12284 IF(IPROC.EQ.7) THEN
12285 ID3A = ID3A+1
12286 NDD = NDD + 1
12287 ENDIF
9aaba0d6 12288 IDIA = IDIA+MHDIR
12289
12290C-----------------------------------------------------------------------
12291C initialize control statistics
12292
12293 ELSE IF(IPROC.EQ.-1) THEN
12294 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12295 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12296 CALL PHO_SEAFLA(-1,0,0,DUM)
12297 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12298 & CALL PHO_QELAST(-1,1,2,0)
12299 ISPS = 0
12300 ISPA = 0
12301 ISRS = 0
12302 ISRA = 0
12303 IHPS = 0
12304 IHPA = 0
12305 ISTS = 0
12306 ISTA = 0
12307 ISLS = 0
12308 ISLA = 0
12309 ID1S = 0
12310 ID1A = 0
12311 ID2S = 0
12312 ID2A = 0
12313 ID3S = 0
12314 ID3A = 0
12315 IDPS = 0
12316 IDPA = 0
12317 IDIS = 0
12318 IDIA = 0
12319 CALL PHO_STRING(-1,IREJ)
12320 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12321 RETURN
12322
12323C-----------------------------------------------------------------------
12324C produce statistics summary
12325
12326 ELSE IF(IPROC.EQ.-2) THEN
12327 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12328 IF(IDEB(3).GE.0) THEN
12329 WRITE(LO,'(/1X,A,/1X,A)')
12330 & 'PHO_PARTON: internal statistics on parton configurations',
12331 & '--------------------------------------------------------'
12332 WRITE(LO,'(5X,A)') 'process sampled accepted'
12333 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12334 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12335 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12336 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12337 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12338 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12339 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12340 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12341 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12342 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12343 ENDIF
12344 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12345 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12346 & CALL PHO_QELAST(-2,1,2,0)
12347 CALL PHO_STRING(-2,IREJ)
12348 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12349 CALL PHO_SEAFLA(-2,0,0,DUM)
12350 RETURN
12351 ELSE
12352 WRITE(LO,'(1X,A,I2)')
12353 & 'PARTON:ERROR: unknown process ID ',IPROC
12354 STOP
12355 ENDIF
12356
12357 END
12358
12359*$ CREATE PHO_MCINI.FOR
12360*COPY PHO_MCINI
12361CDECK ID>, PHO_MCINI
12362 SUBROUTINE PHO_MCINI
12363C********************************************************************
12364C
12365C initialization of MC event generation
12366C
12367C********************************************************************
12368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12369 SAVE
12370
12371 PARAMETER ( PIMASS = 0.13D0,
12372 & TINY = 1.D-10 )
12373
12374C input/output channels
12375 INTEGER LI,LO
12376 COMMON /POINOU/ LI,LO
12377C event debugging information
12378 INTEGER NMAXD
12379 PARAMETER (NMAXD=100)
12380 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12381 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12382 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12383 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12384C model switches and parameters
12385 CHARACTER*8 MDLNA
12386 INTEGER ISWMDL,IPAMDL
12387 DOUBLE PRECISION PARMDL
12388 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12389C general process information
12390 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12392C cross sections
12393 INTEGER IPFIL,IFAFIL,IFBFIL
12394 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12395 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12396 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12397 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12398 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12399 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12400 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12401 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12402 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12403 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12404 & IPFIL,IFAFIL,IFBFIL
12405C hard cross sections and MC selection weights
12406 INTEGER Max_pro_2
12407 PARAMETER ( Max_pro_2 = 16 )
12408 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12409 & MH_acc_1,MH_acc_2
12410 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12411 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12412 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12413 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12414 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12415 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12416C interpolation tables for hard cross section and MC selection weights
12417 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12418 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12419 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12420 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12421 & HQ2a_tab,HQ2b_tab,HEcm_tab
12422 COMMON /POHTAB/
12423 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12424 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12425 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12426 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12427 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12428 & HEcm_tab(1:Max_tab_E,0:4),
12429 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12430C global event kinematics and particle IDs
12431 INTEGER IFPAP,IFPAB
12432 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12433 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12434C obsolete cut-off information
12435 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12436 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12437C event weights and generated cross section
12438 INTEGER IPOWGC,ISWCUT,IVWGHT
12439 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12440 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12441 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12442C cut probability distribution
12443 INTEGER IEETA1,IIMAX,KKMAX
12444 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12445 INTEGER IEEMAX,IMAX,KMAX
12446 REAL PROB
12447 DOUBLE PRECISION EPTAB
12448 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12449 & IEEMAX,IMAX,KMAX
12450C energy-interpolation table
12451 INTEGER IEETA2
12452 PARAMETER ( IEETA2 = 20 )
12453 INTEGER ISIMAX
12454 DOUBLE PRECISION SIGTAB,SIGECM
12455 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12456
12457 CHARACTER*15 PHO_PNAME
12458 DIMENSION ECMF(4)
12459
12460 DATA XMPOM / 0.766D0 /
12461
12462C initialize fragmentation
12463 CALL PHO_FRAINI(ISWMDL(6))
12464
12465C reset interpolation tables
12466 DO 50 I=1,4
12467 DO 60 J=1,10
12468 DO 70 K=1,70
12469 SIGTAB(I,K,J) = 0.D0
12470 70 CONTINUE
12471 SIGECM(I,J) = 0.D0
12472 60 CONTINUE
12473 50 CONTINUE
12474
12475C max. number of allowed colors (large N expansion)
12476 IC1 = 0
12477 IC2 = 10000
12478 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12479
12480C lower energy limit of initialization
12481 ETABLO = PARMDL(19)
12482 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12483
12484 WRITE(LO,'(/,1X,A,2F12.1)')
12485 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12486 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12487 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12488 & PMASS(1),PVIRT(1)
12489 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12490 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12491 & PMASS(2),PVIRT(2)
12492
12493C cuts on probabilities of multiple interactions
12494 IMAX = MIN(IPAMDL(32),IIMAX)
12495 KMAX = MIN(IPAMDL(33),KKMAX)
12496 AH = 2.D0*PTCUT(1)/ECM
12497 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12498 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12499
12500C hard interpolation table
12501 ECMF(1) = ECM
12502 ECMF(2) = 0.9D0*ECMF(1)
12503 ECMF(3) = ECMF(2)
12504 ECMF(4) = ECMF(2)
12505 do k=1,4
12506 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12507 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12508 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12509 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12510 enddo
12511
12512C initialization of hard scattering for all channels and cutoffs
12513 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12514 I0 = 4
12515 IF(ISWMDL(2).EQ.0) I0 = 1
12516 DO 110 I=I0,1,-1
12517 CALL PHO_HARMCI(I,ECMF(I))
12518 110 CONTINUE
12519
12520C dimension of interpolation table of cut probabilities
12521 IEEMAX = MIN(IPAMDL(31),IEETA1)
12522 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12523 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12524 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12525 ISIMAX = IEEMAX
12526
12527C calculate probability distribution
12528 I0 = 4
12529 IFT1 = IFPAP(1)
12530 IFT2 = IFPAP(2)
12531 XMT1 = PMASS(1)
12532 XMT2 = PMASS(2)
12533 XVT1 = PVIRT(1)
12534 XVT2 = PVIRT(2)
12535 IF(ISWMDL(2).EQ.0) I0 = 1
12536 DO 150 IP=I0,1,-1
12537 ECMPRO = ECMF(IP)*1.001D0
12538 IF(IP.EQ.4) THEN
12539 IFPAP(1) = 990
12540 IFPAP(2) = 990
12541 PMASS(1) = XMPOM
12542 PMASS(2) = XMPOM
12543 PVIRT(1) = 0.D0
12544 PVIRT(2) = 0.D0
12545 ELSE IF(IP.EQ.3) THEN
12546 IFPAP(1) = IFT2
12547 IFPAP(2) = 990
12548 PMASS(1) = XMT2
12549 PMASS(2) = XMPOM
12550 PVIRT(1) = XVT2
12551 PVIRT(2) = 0.D0
12552 ELSE IF(IP.EQ.2) THEN
12553 IFPAP(1) = IFT1
12554 IFPAP(2) = 990
12555 PMASS(1) = XMT1
12556 PMASS(2) = XMPOM
12557 PVIRT(1) = XVT1
12558 PVIRT(2) = 0.D0
12559 ELSE
12560 IFPAP(1) = IFT1
12561 IFPAP(2) = IFT2
12562 PMASS(1) = XMT1
12563 PMASS(2) = XMT2
12564 PVIRT(1) = XVT1
12565 PVIRT(2) = XVT2
12566 ENDIF
12567 IF(IEEMAX.GT.1) THEN
12568 IF(IP.EQ.1) THEN
12569 ELMIN = LOG(ETABLO)
12570 ELSE
12571 ELMIN = LOG(2.5D0)
12572 ENDIF
12573 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12574 DO 100 I=1,IEEMAX
12575 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12576 CALL PHO_PRBDIS(IP,ECMPRO,I)
12577 100 CONTINUE
12578 ELSE
12579 CALL PHO_PRBDIS(IP,ECMPRO,1)
12580 ENDIF
12581
12582C debug output of cross section tables
12583 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12584 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12585 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12586 &'Table of total cross sections (mb) for particle combination',IP,
12587 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12588 &'-------------------------------------------------------------'
12589 DO 200 I=1,IEEMAX
12590 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12591 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12592 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12593 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12594 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12595 200 CONTINUE
12596 201 CONTINUE
12597 IF(IDEB(62).GE.2) THEN
12598 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12599 &'Table of partial x-sections (mb) for particle combination',IP,
12600 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12601 &'--------------------------------------------------------------'
12602 DO 205 I=1,IEEMAX
12603 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12604 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12605 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12606 205 CONTINUE
12607 ENDIF
12608 IF(IDEB(62).GE.2) THEN
12609 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12610 &'Table of born graph x-sections (mb) for particle combination',IP,
12611 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12612 &'-------------------------------------------------------------'
12613 DO 210 I=1,IEEMAX
12614 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12615 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12616 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12617 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12618 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12619 & +SIGTAB(IP,68,I)
12620 210 CONTINUE
12621 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12622 &'Table of unitarized x-sections (mb) for particle combination',IP,
12623 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12624 &'-------------------------------------------------------------'
12625 DO 215 I=1,IEEMAX
12626 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12627 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12628 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12629 215 CONTINUE
12630 ENDIF
12631 IF(IDEB(62).GE.1) THEN
12632 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12633 &'Table of expected average number of cuts in non-diff events:',
12634 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12635 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12636 &'---------------------------------------------'
12637 DO 220 I=1,IEEMAX
12638 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12639 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12640 & SIGTAB(IP,76,I)
12641 220 CONTINUE
12642 IF(IP.EQ.1) THEN
12643 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12644 & 'Table of rapidity gap survival probability (high-mass diff.):',
12645 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12646 & '---------------------------------------------------'
12647 DO 230 I=1,IEEMAX
12648 IF(SIGECM(IP,I).GT.10.D0) THEN
12649 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12650 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12651 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12652 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12653 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12654 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12655 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12656 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12657 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12658 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12659 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12660 ENDIF
12661 230 CONTINUE
12662 ENDIF
12663 ENDIF
12664 ENDIF
12665 150 CONTINUE
12666
12667C simulate only hard scatterings
12668 IF(ISWMDL(2).EQ.0) THEN
12669 WRITE(LO,'(2(/1X,A))')
12670 & 'WARNING: generation of hard scatterings only!',
12671 & '============================================='
12672 DO 151 I=2,7
12673 IPRON(I,1) = 0
12674 151 CONTINUE
12675 DO 152 K=2,4
12676 DO 153 I=1,15
12677 IPRON(I,K) = 0
12678 153 CONTINUE
12679 152 CONTINUE
12680 SIGGEN(4) = 0.D0
12681 DO 160 I=1,IEEMAX
12682 SIGMAX = 0.D0
12683 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12684 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12685 IF(SIGMAX.GT.SIGGEN(4)) THEN
12686 ISIGM = I
12687 SIGGEN(4) = SIGMAX
12688 ENDIF
12689 160 CONTINUE
12690 ELSE
12691 WRITE(LO,'(2(/1X,A))')
12692 & 'activated processes, cross section',
12693 & '----------------------------------'
12694 WRITE(LO,'(5X,A,I3,2X,3I3)')
12695 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12696 WRITE(LO,'(5X,A,I3,2X,3I3)')
12697 & ' elastic scattering',(IPRON(2,K),K=1,4)
12698 WRITE(LO,'(5X,A,I3,2X,3I3)')
12699 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12700 WRITE(LO,'(5X,A,I3,2X,3I3)')
12701 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12702 WRITE(LO,'(5X,A,I3,2X,3I3)')
12703 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12704 WRITE(LO,'(5X,A,I3,2X,3I3)')
12705 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12706 WRITE(LO,'(5X,A,I3,2X,3I3)')
12707 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12708 WRITE(LO,'(5X,A,I3,2X,3I3)')
12709 & ' direct photon processes',(IPRON(8,K),K=1,4)
12710
12711C calculate effective cross section
12712 SIGGEN(4) = 0.D0
12713 DO 165 I=1,IEEMAX
12714 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12715 & PVIRT(1),PVIRT(2))
12716 SIGMAX = 0.D0
12717 if(iswmdl(2).ge.1) then
12718 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12719 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12720 & -SIGLDD-SIGHDD-SIGDIR
12721 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12722 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12723 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12724 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12725 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12726 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12727 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12728 else
12729 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12730 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12731 endif
12732 IF(SIGMAX.GT.SIGGEN(4)) THEN
12733 ISIGM = I
12734 SIGGEN(4) = SIGMAX
12735 ENDIF
12736 165 CONTINUE
12737 ENDIF
12738
12739C debug output
12740 IF(SIGGEN(4).LT.1.D-20) THEN
12741 WRITE(LO,'(//1X,A)')
12742 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12743 STOP
12744 ENDIF
12745 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12746 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12747 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12748
12749 END
12750
12751*$ CREATE PHO_REJSTA.FOR
12752*COPY PHO_REJSTA
12753CDECK ID>, PHO_REJSTA
12754 SUBROUTINE PHO_REJSTA(IMODE)
12755C********************************************************************
12756C
12757C MC rejection counting
12758C
12759C input IMODE -1 initialization
12760C -2 output of statistics
12761C
12762C********************************************************************
12763 IMPLICIT NONE
12764 SAVE
12765
12766C input/output channels
12767 INTEGER LI,LO
12768 COMMON /POINOU/ LI,LO
12769C event debugging information
12770 INTEGER NMAXD
12771 PARAMETER (NMAXD=100)
12772 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12773 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12774 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12775 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12776C internal rejection counters
12777 INTEGER NMXJ
12778 PARAMETER (NMXJ=60)
12779 CHARACTER*10 REJTIT
12780 INTEGER IFAIL
12781 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12782
12783 INTEGER IMODE
12784
12785 INTEGER I
12786
12787C initialization
12788 IF(IMODE.EQ.-1) THEN
12789 DO 100 I=1,NMXJ
12790 IFAIL(I) = 0
12791 100 CONTINUE
12792C
12793 REJTIT(1) = 'PARTON ALL'
12794 REJTIT(2) = 'STDPAR ALL'
12795 REJTIT(3) = 'STDPAR DPO'
12796 REJTIT(4) = 'POMSCA ALL'
12797 REJTIT(5) = 'POMSCA INT'
12798 REJTIT(6) = 'POMSCA KIN'
12799 REJTIT(7) = 'DIFDIS ALL'
12800 REJTIT(8) = 'POSPOM ALL'
12801 REJTIT(9) = 'HRES.DIF.1'
12802 REJTIT(10) = 'HDIR.DIF.1'
12803 REJTIT(11) = 'HRES.DIF.2'
12804 REJTIT(12) = 'HDIR.DIF.2'
12805 REJTIT(13) = 'DIFDIS INT'
12806 REJTIT(14) = 'HADRON SP2'
12807 REJTIT(15) = 'HADRON SP3'
12808 REJTIT(16) = 'HARDIR ALL'
12809 REJTIT(17) = 'HARDIR INT'
12810 REJTIT(18) = 'HARDIR KIN'
12811 REJTIT(19) = 'MCHECK BAR'
12812 REJTIT(20) = 'MCHECK MES'
12813 REJTIT(21) = 'DIF.DISS.1'
12814 REJTIT(22) = 'DIF.DISS.2'
12815 REJTIT(23) = 'STRFRA ALL'
12816 REJTIT(24) = 'MSHELL CHA'
12817 REJTIT(25) = 'PARTPT SOF'
12818 REJTIT(26) = 'PARTPT HAR'
12819 REJTIT(27) = 'INTRINS KT'
12820 REJTIT(28) = 'HACHEK DIR'
12821 REJTIT(29) = 'HACHEK RES'
12822 REJTIT(30) = 'STRING ALL'
12823 REJTIT(31) = 'POMSCA INT'
12824 REJTIT(32) = 'DIFF SLOPE'
12825 REJTIT(33) = 'GLU2QU ALL'
12826 REJTIT(34) = 'MASCOR ALL'
12827 REJTIT(35) = 'PARCOR ALL'
12828 REJTIT(36) = 'MSHELL PAR'
12829 REJTIT(37) = 'MSHELL ALL'
12830 REJTIT(38) = 'POMCOR ALL'
12831 REJTIT(39) = 'DB-POM KIN'
12832 REJTIT(40) = 'DB-POM ALL'
12833 REJTIT(41) = 'SOFTXX ALL'
12834 REJTIT(42) = 'SOFTXX PSP'
12835
12836C write output
12837 ELSE IF(IMODE.EQ.-2) THEN
12838 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12839 & '--------------------------------'
12840 DO 300 I=1,NMXJ
12841 IF(IFAIL(I).GT.0)
12842 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12843 300 CONTINUE
12844 ELSE
12845 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12846 ENDIF
12847
12848 END
12849
12850*$ CREATE PHO_POSPOM.FOR
12851*COPY PHO_POSPOM
12852CDECK ID>, PHO_POSPOM
12853 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12854C***********************************************************************
12855C
12856C registration of one cut pomeron (soft/semihard)
12857C
12858C input: IP particle combination the pomeron belongs to
12859C IND1,2 position of X values in /POSOFT/
12860C 1 corresponds to a valence-pomeron
12861C IGEN production process of mother particles
12862C IPOM pomeron number
12863C KCUT total number of cut pomerons and reggeons
12864C
12865C output: ISWAP exchange of x values
12866C IND1,2 increased by the number of partons belonging
12867C to the generated pomeron cut
12868C IREJ success/failure
12869C
12870C**********************************************************************
12871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12872 SAVE
12873
12874 PARAMETER ( DEPS = 1.D-8 )
12875
12876C input/output channels
12877 INTEGER LI,LO
12878 COMMON /POINOU/ LI,LO
12879C event debugging information
12880 INTEGER NMAXD
12881 PARAMETER (NMAXD=100)
12882 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12883 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12884 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12885 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12886C internal rejection counters
12887 INTEGER NMXJ
12888 PARAMETER (NMXJ=60)
12889 CHARACTER*10 REJTIT
12890 INTEGER IFAIL
12891 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12892C model switches and parameters
12893 CHARACTER*8 MDLNA
12894 INTEGER ISWMDL,IPAMDL
12895 DOUBLE PRECISION PARMDL
12896 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12897C general process information
12898 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12899 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12900C global event kinematics and particle IDs
12901 INTEGER IFPAP,IFPAB
12902 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12903 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12904C data of c.m. system of Pomeron / Reggeon exchange
12905 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12906 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12907 & SIDP,CODP,SIFP,COFP
12908 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12909 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12910 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12911C obsolete cut-off information
12912 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12913 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12914C energy-interpolation table
12915 INTEGER IEETA2
12916 PARAMETER ( IEETA2 = 20 )
12917 INTEGER ISIMAX
12918 DOUBLE PRECISION SIGTAB,SIGECM
12919 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12920C light-cone x fractions and c.m. momenta of soft cut string ends
12921 INTEGER MAXSOF
12922 PARAMETER ( MAXSOF = 50 )
12923 INTEGER IJSI2,IJSI1
12924 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12925 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12926 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12927 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12928C standard particle data interface
12929 INTEGER NMXHEP
12930 PARAMETER (NMXHEP=4000)
12931 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12932 DOUBLE PRECISION PHEP,VHEP
12933 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12934 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12935 & VHEP(4,NMXHEP)
12936C extension to standard particle data interface (PHOJET specific)
12937 INTEGER IMPART,IPHIST,ICOLOR
12938 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12939C table of particle indices for recursive PHOJET calls
12940 INTEGER MAXIPX
12941 PARAMETER ( MAXIPX = 100 )
12942 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12943 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12944 & IPOIX1,IPOIX2,IPOIX3
12945
12946 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12947
12948 IREJ = 0
12949 ISWAP = 0
12950 JM1 = NPOSP(1)
12951 JM2 = NPOSP(2)
12952 INDX1 = IND1
12953 INDX2 = IND2
12954 EA1 = XS1(IND1)*ECMP/2.D0
12955 EA2 = XS1(IND1+1)*ECMP/2.D0
12956 EB1 = XS2(IND2)*ECMP/2.D0
12957 EB2 = XS2(IND2+1)*ECMP/2.D0
12958 CMASS1 = MIN(EA1,EA2)
12959 CMASS2 = MIN(EB1,EB2)
12960
12961C debug output
12962 IF(IDEB(9).GE.20) THEN
12963 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12964 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12965 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12966 & CMASS1,CMASS2
12967 ENDIF
12968
12969C flavours
12970 IF(IND1.EQ.1) THEN
12971 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12972 ELSE
12973 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12974 ENDIF
12975 IF(IND2.EQ.1) THEN
12976 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12977 ELSE
12978 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12979 ENDIF
12980 DO 75 I=1,4
12981 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12982 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12983 75 CONTINUE
12984
12985C pomeron resolved?
12986 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12987C find energy for cross section calculation
12988 IF(IPAMDL(16).EQ.2) THEN
12989 ESUB = ECMP
12990 ELSE IF(IPAMDL(16).EQ.3) THEN
12991 IF(IPROCE.EQ.1) THEN
12992 ESUB = ECM
12993 ELSE
12994 ESUB = ECMP
12995 ENDIF
12996 ELSE
12997 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12998 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
12999 ENDIF
13000C load cross sections from interpolation table
13001 IF(ESUB.LE.SIGECM(IP,1)) THEN
13002 I1 = 1
13003 I2 = 2
13004 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13005 DO 50 I=2,ISIMAX
13006 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13007 50 CONTINUE
13008 200 CONTINUE
13009 I1 = I-1
13010 I2 = I
13011 ELSE
13012 WRITE(LO,'(/1X,A,2E12.3)')
13013 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13014 CALL PHO_PREVNT(-1)
13015 I1 = ISIMAX-1
13016 I2 = ISIMAX
13017 ENDIF
13018 FAC2=0.D0
13019 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13020 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13021 FAC1=1.D0-FAC2
13022C calculate weights
13023* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13024* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13025* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13026* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13027* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13028* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13029
13030 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13031 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13032 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13033 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13034 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13035 & +SIGTAB(IP,64,I2))
13036 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13037 & +SIGTAB(IP,64,I1))
13038 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13039 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13040 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13041 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13042
13043C one-pomeron cut
13044 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13045C central diff. cut
13046 WGX(2) = WGXCDF
13047C diff. diss. of particle 1
13048 WGX(3) = WGXHSD(1)
13049C diff. diss. of particle 2
13050 WGX(4) = WGXHSD(2)
13051C double diff. dissociation
13052 WGX(5) = WGXHDD
13053C two-pomeron cut
13054 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13055
13056* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13057* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13058* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13059* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13060* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13061* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13062* ENDIF
13063
13064 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13065
13066C selection loop
13067 205 CONTINUE
13068 XI = DT_RNDM(SUM)*SUM
13069 I = 0
13070 SUM = 0.D0
13071 210 CONTINUE
13072 I = I+1
13073 SUM = SUM+WGX(I)
13074 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13075C phase space correction
13076 IF(I.NE.1) THEN
13077 ISAM = 4
13078 IF(I.EQ.6) ISAM = 8
13079 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13080* IF(DT_RNDM(SUM).GT.PACC) I=1
13081 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13082 ENDIF
13083
13084C do not generate diffraction for events with only one cut pomeron
13085 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13086
13087C do not generate recursive calls for remants with
13088C diquark-anti-diquark flavour contents
13089 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13090 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13091
13092C debug output
13093 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13094 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13095
13096 IF(I.GT.1) THEN
13097C second scattering needed
13098 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13099 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13100 IDPD1 = IPHO_ID2PDG(IDHA1)
13101 IDPD2 = IPHO_ID2PDG(IDHA2)
13102
13103 if(INDX1.eq.1) then
13104 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13105 & IGEN_had = IGEN
13106 else
13107 IGEN_had = -IGEN
13108 endif
13109 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13110 & IPOM,IGEN_had,0,0,IPOS1,1)
13111
13112 if(INDX2.eq.1) then
13113 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13114 & IGEN_had = IGEN
13115 else
13116 IGEN_had = -IGEN
13117 endif
13118 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13119 & IPOM,IGEN_had,0,0,IPOS1,1)
13120
13121 IND1 = IND1+2
13122 IND2 = IND2+2
13123C update index
13124 IPOIX2 = IPOIX2+1
13125 IF(IPOIX2.GT.MAXIPX) THEN
13126 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13127 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13128 IREJ = 1
13129 RETURN
13130 ENDIF
13131 IPORES(IPOIX2) = I+2
13132 IPOPOS(1,IPOIX2) = IPOS1-1
13133 IPOPOS(2,IPOIX2) = IPOS1
13134 RETURN
13135 ENDIF
13136 ENDIF
13137
13138 100 CONTINUE
13139 IF(ISWMDL(12).EQ.0) THEN
13140C sample colors
13141 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13142 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13143
13144C purely gluonic pomeron or sea strings formed by gluons
13145
13146 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13147 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13148 IFLA1 = 21
13149 IFLA2 = 21
13150 ENDIF
13151 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13152 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13153 IFLB1 = 21
13154 IFLB2 = 21
13155 ENDIF
13156
13157C color connection
13158 IF(IFLA1.NE.21) THEN
13159 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13160 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13161 & CALL PHO_SWAPI(ICA1,ICD1)
13162 ENDIF
13163 IF(IFLB1.NE.21) THEN
13164 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13165 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13166 & CALL PHO_SWAPI(ICB1,ICC1)
13167 ENDIF
13168 ISWAP = 0
13169 IF(ICA1*ICB1.GT.0) THEN
13170 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13171 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13172 CALL PHO_SWAPI(IFLA1,IFLA2)
13173 CALL PHO_SWAPI(ICA1,ICD1)
13174 ELSE
13175 CALL PHO_SWAPI(IFLB1,IFLB2)
13176 CALL PHO_SWAPI(ICB1,ICC1)
13177 ENDIF
13178 ELSE IF(IND1.NE.1) THEN
13179 CALL PHO_SWAPI(IFLA1,IFLA2)
13180 CALL PHO_SWAPI(ICA1,ICD1)
13181 ELSE IF(IND2.NE.1) THEN
13182 CALL PHO_SWAPI(IFLB1,IFLB2)
13183 CALL PHO_SWAPI(ICB1,ICC1)
13184 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13185 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13186 CALL PHO_SWAPI(IFLA1,IFLA2)
13187 CALL PHO_SWAPI(ICA1,ICD1)
13188 ELSE
13189 CALL PHO_SWAPI(IFLB1,IFLB2)
13190 CALL PHO_SWAPI(ICB1,ICC1)
13191 ENDIF
13192 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13193 CALL PHO_SWAPI(IFLA1,IFLA2)
13194 CALL PHO_SWAPI(ICA1,ICD1)
13195 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13196 CALL PHO_SWAPI(IFLB1,IFLB2)
13197 CALL PHO_SWAPI(ICB1,ICC1)
13198 ELSE
13199 ISWAP = 1
13200 IF(IDEB(9).GE.5) THEN
13201 WRITE(LO,'(1X,A,I12)')
13202 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13203 WRITE(LO,'(5X,A,4I7)')
13204 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13205 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13206 ENDIF
13207 ENDIF
13208 ENDIF
13209
13210C registration
13211
13212C purely gluonic pomeron or sea strings formed by gluons
13213 IF(IFLA1.EQ.21) THEN
13214 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13215 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13216 IND1 = IND1+2
13217
13218C strings formed by quarks
13219 ELSE
13220C valence quark labels
13221 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13222 & .and.(IDHEP(JM1).NE.990)) THEN
13223 ICA2 = 1
13224 ICD2 = 1
13225 ENDIF
13226C registration
13227 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13228 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13229 & ICA2,IPOS1,1)
13230 IND1 = IND1+1
13231 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13232 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13233 & ICD2,IPOS,1)
13234 IND1 = IND1+1
13235 ENDIF
13236
13237C purely gluonic pomeron or sea strings formed by gluons
13238 IF(IFLB1.EQ.21) THEN
13239 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13240 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13241 IND2 = IND2+2
13242
13243C strings formed by quarks
13244 ELSE
13245C valence quark labels
13246 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13247 & .and.(IDHEP(JM2).NE.990)) THEN
13248 ICB2 = 1
13249 ICC2 = 1
13250 ENDIF
13251C registration
13252 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13253 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13254 & ICB2,IPOS,1)
13255 IND2 = IND2+1
13256 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13257 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13258 & ICC2,IPOS2,1)
13259 IND2 = IND2+1
13260 ENDIF
13261
13262C soft pt assignment
13263 IF(ISWMDL(18).EQ.0) THEN
13264 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13265 IF(IREJ.NE.0) THEN
13266 IFAIL(25) = IFAIL(25)+1
13267 RETURN
13268 ENDIF
13269 ENDIF
13270 ELSE
13271* CALL PHO_BFKL(P1,P2,IPART,IREJ)
13272* IF(IREJ.NE.0) RETURN
13273 ENDIF
13274
13275 END
13276
13277*$ CREATE PHO_HADSP2.FOR
13278*COPY PHO_HADSP2
13279CDECK ID>, PHO_HADSP2
13280 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13281C***********************************************************************
13282C
13283C split hadron momentum XMAX into two partons using
13284C lower cut-off: AS
13285C
13286C input: IFLB compressed particle code of particle to split
13287C XS1 sum of x values already selected
13288C XMAX maximal x possible
13289C
13290C output: XS1 new sum of x values (without first one)
13291C XSOFT1 field of selected x values
13292C
13293C**********************************************************************
13294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13295 SAVE
13296
13297 PARAMETER ( DEPS = 1.D-8 )
13298
13299 DIMENSION XSOFT1(50)
13300
13301C input/output channels
13302 INTEGER LI,LO
13303 COMMON /POINOU/ LI,LO
13304C event debugging information
13305 INTEGER NMAXD
13306 PARAMETER (NMAXD=100)
13307 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13308 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13309 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13310 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13311C internal rejection counters
13312 INTEGER NMXJ
13313 PARAMETER (NMXJ=60)
13314 CHARACTER*10 REJTIT
13315 INTEGER IFAIL
13316 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13317C data on most recent hard scattering
13318 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13319 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13320 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13321 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13322 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13323 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13324 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13325 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13326 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13327
13328C model exponents
13329 DATA PVMES1 /-0.5D0/
13330 DATA PVMES2 /-0.5D0/
13331 DATA PVBAR1 / 1.5D0/
13332 DATA PVBAR2 /-0.5D0/
13333C
13334 IREJ = 0
13335 ITMAX = 100
13336C
13337C mesonic particle
13338 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13339 XPOT1 = PVMES1+1.D0
13340 XPOT2 = PVMES2+1.D0
13341C baryonic particle
13342 ELSE
13343 XPOT1 = PVBAR1+1.D0
13344 XPOT2 = PVBAR2+1.D0
13345 ENDIF
13346 ITER = 0
13347 XREST= 1.D0-XS1
13348C selection loop
13349 100 CONTINUE
13350 ITER = ITER+1
13351 IF(ITER.GE.ITMAX) THEN
13352 IF(IDEB(39).GE.3) THEN
13353 WRITE(LO,'(1X,A,I8)')
13354 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13355 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13356 ENDIF
13357 IFAIL(14) = IFAIL(14)+1
13358 IREJ = 1
13359 RETURN
13360 ENDIF
13361 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13362 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13363 XSS1 = XS1 + ZZ
13364 IF((1.D0-XSS1).LT.AS) GOTO 100
13365C
13366 XS1 = XSS1
13367 XSOFT1(1) = 1.D0-XSS1
13368 XSOFT1(2) = ZZ
13369C debug output
13370 IF(IDEB(39).GE.10) THEN
13371 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13372 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13373 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13374 ENDIF
13375 END
13376
13377*$ CREATE PHO_HADSP3.FOR
13378*COPY PHO_HADSP3
13379CDECK ID>, PHO_HADSP3
13380 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13381C***********************************************************************
13382C
13383C split hadron momentum XMAX into diquark & quark pair
13384C using lower cut-off: AS
13385C
13386C input: IFLB compressed particle code of particle to split
13387C XS1 sum of x values already selected
13388C XMAX maximal x possible
13389C
13390C output: XS1 new sum of x values
13391C XSOFT1 field of selected x values
13392C
13393C
13394C**********************************************************************
13395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13396 SAVE
13397 PARAMETER ( DEPS = 1.D-8 )
13398
13399 DIMENSION XSOFT1(50),XSOFT2(50)
13400
13401C input/output channels
13402 INTEGER LI,LO
13403 COMMON /POINOU/ LI,LO
13404C event debugging information
13405 INTEGER NMAXD
13406 PARAMETER (NMAXD=100)
13407 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13408 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13409 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13410 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13411C internal rejection counters
13412 INTEGER NMXJ
13413 PARAMETER (NMXJ=60)
13414 CHARACTER*10 REJTIT
13415 INTEGER IFAIL
13416 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13417C data of c.m. system of Pomeron / Reggeon exchange
13418 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13419 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13420 & SIDP,CODP,SIFP,COFP
13421 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13422 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13423 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13424
13425 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13426
13427C model exponents
13428 DATA PVMES1 /-0.5D0/
13429 DATA PVMES2 /-0.5D0/
13430 DATA PSMES /-0.99D0/
13431 DATA PVBAR1 / 1.5D0/
13432 DATA PVBAR2 /-0.5D0/
13433 DATA PSBAR /-0.99D0/
13434C
13435 IREJ = 0
13436C
13437C determine exponents
13438C particle 1
13439C
13440 XMMIN = 0.3D0/ECMP
13441 XBMIN = 1.6D0/ECMP
13442C mesonic particle
13443 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13444 XPOT1(1) = PVMES1
13445 XMIN(1,1) = XMMIN
13446 XPOT1(2) = PVMES2
13447 XMIN(1,2) = XMMIN
13448 XPOT1(3) = PSMES
13449 XMIN(1,3) = XMMIN
13450C baryonic particle
13451 ELSE
13452 XPOT1(1) = PVBAR1
13453 XMIN(1,1) = XBMIN
13454 XPOT1(2) = PVBAR2
13455 XMIN(1,2) = XMMIN
13456 XPOT1(3) = PSBAR
13457 XMIN(1,3) = XMMIN
13458 ENDIF
13459C particle 2
13460C mesonic particle
13461 XPOT2(1) = PVMES1
13462 XMIN(2,1) = XMMIN
13463 XPOT2(2) = PVMES2
13464 XMIN(2,2) = XMMIN
13465 XPOT2(3) = PSMES
13466 XMIN(2,3) = XMMIN
13467C
13468 XDUM1 = 0.01D0
13469 XDUM2 = 0.99D0
13470 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13471 & XSOFT1,XSOFT2,IREJ)
13472C rejection?
13473 IF(IREJ.NE.0) THEN
13474 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13475 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13476 IFAIL(15) = IFAIL(15)+1
13477 IREJ = 1
13478 RETURN
13479 ENDIF
13480C debug output
13481 IF(IDEB(74).GE.10) THEN
13482 WRITE(LO,'(1X,A,I6,2E12.4)')
13483 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13484 DO 100 I=1,3
13485 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13486 100 CONTINUE
13487 ENDIF
13488
13489 END
13490
13491*$ CREATE PHO_SOFTXX.FOR
13492*COPY PHO_SOFTXX
13493CDECK ID>, PHO_SOFTXX
13494 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13495 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13496C***********************************************************************
13497C
13498C select soft x values
13499C
13500C input: JM1,JM2 mother particle index in POEVT1
13501C (0 flavour not known before)
13502C MSPAR1,2 number of x values to select
13503C IVAL1,2 number valence quarks involved in hard
13504C scattering (0,1,2)
13505C MSM1,2 minimum number of soft x to get sampled
13506C XSUM1,2 sum of all x values samples up this call
13507C XMAX1,2 max. x value
13508C
13509C output XSUM1,2 new sum of x-values sampled
13510C XS1,2 field containing sampled x values
13511C
13512C x values of valence partons are first given
13513C
13514C***********************************************************************
13515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13516 SAVE
13517
13518C input/output channels
13519 INTEGER LI,LO
13520 COMMON /POINOU/ LI,LO
13521C event debugging information
13522 INTEGER NMAXD
13523 PARAMETER (NMAXD=100)
13524 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13525 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13526 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13527 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13528C internal rejection counters
13529 INTEGER NMXJ
13530 PARAMETER (NMXJ=60)
13531 CHARACTER*10 REJTIT
13532 INTEGER IFAIL
13533 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13534C model switches and parameters
13535 CHARACTER*8 MDLNA
13536 INTEGER ISWMDL,IPAMDL
13537 DOUBLE PRECISION PARMDL
13538 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13539C data of c.m. system of Pomeron / Reggeon exchange
13540 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13541 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13542 & SIDP,CODP,SIFP,COFP
13543 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13544 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13545 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13546C standard particle data interface
13547 INTEGER NMXHEP
13548 PARAMETER (NMXHEP=4000)
13549 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13550 DOUBLE PRECISION PHEP,VHEP
13551 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13552 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13553 & VHEP(4,NMXHEP)
13554C extension to standard particle data interface (PHOJET specific)
13555 INTEGER IMPART,IPHIST,ICOLOR
13556 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13557C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13558 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13559 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13560 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13561 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13562C obsolete cut-off information
13563 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13564 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13565C data on most recent hard scattering
13566 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13567 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13568 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13569 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13570 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13571 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13572 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13573 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13574 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13575
13576 DIMENSION XS1(*),XS2(*)
13577
13578 INTEGER MAXPOT
13579 PARAMETER ( MAXPOT = 50 )
13580 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13581
13582 IREJ = 0
13583
13584 MSMAX = MAX(MSPAR1,MSPAR2)
13585 MSMIN = MAX(MSM1,MSM2)
13586 IF(MSMAX.GT.MAXPOT) THEN
13587 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13588 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13589 IREJ = 1
13590 RETURN
13591 ENDIF
13592C determine exponents
13593 IBAR1 = ipho_bar3(JM1,2)
13594 IBAR2 = ipho_bar3(JM2,2)
13595 ISWAP = 0
13596 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13597C meson-baryon scattering (asymmetric sea)
13598 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13599 PSBAR = PARMDL(53)
13600 PSMES = PARMDL(57)
13601 ELSE
13602 PSBAR = PARMDL(52)
13603 PSMES = PARMDL(56)
13604 ENDIF
13605
13606C lower limits for x sampling
13607 XMMINA = 2.D0*PARMDL(157)/ECMP
13608 XBMINA = 2.D0*PARMDL(158)/ECMP
13609 XSMINA = 2.D0*PARMDL(159)/ECMP
13610 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13611 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13612 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13613 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13614 XMIN1 = MAX(AS/XMAX2,XMIN1)
13615 XMIN2 = MAX(AS/XMAX1,XMIN2)
13616
13617C particle 1
13618 XMMIN1 = MAX(XMIN1,XMMINA)
13619 XBMIN1 = MAX(XMIN1,XBMINA)
13620 XSMIN1 = MAX(XMIN1,XSMINA)
13621C mesonic particle
13622 IF(IBAR1.EQ.0) THEN
13623 IF(IHFLS(1).EQ.0) THEN
13624 XPOT1(1) = PARMDL(62)
13625 XMIN(1,1) = XSMIN1
13626 XPOT1(2) = PARMDL(63)
13627 XMIN(1,2) = XSMIN1
13628 ELSE
13629 XPOT1(1) = PARMDL(54)
13630 XMIN(1,1) = XMMIN1
13631 XPOT1(2) = PARMDL(55)
13632 XMIN(1,2) = XMMIN1
13633 ENDIF
13634 DO 100 I=3-IVAL1,MSMAX
13635 XPOT1(I) = PSMES
13636 XMIN(1,I) = XSMIN1
13637 100 CONTINUE
13638C baryonic particle
13639 ELSE
13640 IF(IHFLS(1).EQ.0) THEN
13641 XPOT1(1) = PARMDL(62)
13642 XMIN(1,1) = XSMIN1
13643 XPOT1(2) = PARMDL(63)
13644 XMIN(1,2) = XSMIN1
13645 ELSE
13646 XPOT1(1) = PARMDL(50)
13647 XMIN(1,1) = XBMIN1
13648 XPOT1(2) = PARMDL(51)
13649 XMIN(1,2) = XMMIN1
13650 ENDIF
13651 DO 200 I=3-IVAL1,MSMAX
13652 XPOT1(I) = PSBAR
13653 XMIN(1,I) = XSMIN1
13654 200 CONTINUE
13655 ENDIF
13656
13657C particle 2
13658 XMMIN2 = MAX(XMIN2,XMMINA)
13659 XBMIN2 = MAX(XMIN2,XBMINA)
13660 XSMIN2 = MAX(XMIN2,XSMINA)
13661C mesonic particle
13662 IF(IBAR2.EQ.0) THEN
13663 IF(IHFLS(2).EQ.0) THEN
13664 XPOT2(1) = PARMDL(62)
13665 XMIN(2,1) = XSMIN2
13666 XPOT2(2) = PARMDL(63)
13667 XMIN(2,2) = XSMIN2
13668 ELSE
13669 XPOT2(1) = PARMDL(54)
13670 XMIN(2,1) = XMMIN2
13671 XPOT2(2) = PARMDL(55)
13672 XMIN(2,2) = XMMIN2
13673 ENDIF
13674 DO 300 I=3-IVAL2,MSMAX
13675 XPOT2(I) = PSMES
13676 XMIN(2,I) = XSMIN2
13677 300 CONTINUE
13678C baryonic particle
13679 ELSE
13680 IF(IHFLS(2).EQ.0) THEN
13681 XPOT2(1) = PARMDL(62)
13682 XMIN(2,1) = XSMIN2
13683 XPOT2(2) = PARMDL(63)
13684 XMIN(2,2) = XSMIN2
13685 ELSE
13686 XPOT2(1) = PARMDL(50)
13687 XMIN(2,1) = XBMIN2
13688 XPOT2(2) = PARMDL(51)
13689 XMIN(2,2) = XMMIN2
13690 ENDIF
13691 DO 400 I=3-IVAL2,MSMAX
13692 XPOT2(I) = PSBAR
13693 XMIN(2,I) = XSMIN2
13694 400 CONTINUE
13695 ENDIF
13696
13697 XSS1 = XSUM1
13698 XSS2 = XSUM2
13699 MSOFT = MSMAX
13700
13701C check limits (important for valences)
13702 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13703 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13704
13705 XMINS1 = XSS1
13706 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13707 XMINS2 = XSS2
13708 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13709 DO 10 I=1,MSOFT
13710 XMINS1 = XMINS1+XMIN(1,I)
13711 XMINS2 = XMINS2+XMIN(2,I)
13712 10 CONTINUE
13713 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13714
13715C try to sample x values
13716 IF(IPAMDL(14).EQ.0) 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(MSOFT.LT.5) THEN
13721 CALL PHO_SELSXR(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 IF(IPAMDL(14).EQ.1) THEN
13728 IF(MSOFT.EQ.2) THEN
13729 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13730 & XS1,XS2,IREJ)
13731 ELSE
13732 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13733 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13734 ENDIF
13735 ELSE IF(IPAMDL(14).EQ.2) THEN
13736 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13737 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13738 ELSE IF(IPAMDL(14).EQ.3) THEN
13739 IF(MSOFT.EQ.2) THEN
13740 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13741 & XS1,XS2,IREJ)
13742 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13743 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13744 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13745 ELSE
13746 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13747 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13748 ENDIF
13749 ELSE
13750 WRITE(LO,'(/,1X,A,I3)')
13751 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13752 STOP
13753 ENDIF
13754 IF(IREJ.NE.0) THEN
13755 IFAIL(41) = IFAIL(41)+1
13756 IF(IDEB(60).GE.2) THEN
13757 WRITE(LO,'(1X,A,I12,4I3)')
13758 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13759 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13760 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13761 & XSUM1,XSUM2,XMAX1,XMAX2
13762 ENDIF
13763 RETURN
13764 ENDIF
13765 IF(MSOFT.NE.MSMAX) THEN
13766 MSDIFF = MSMAX-MSOFT
13767 MSPAR1 = MSPAR1-MSDIFF
13768 MSPAR2 = MSPAR2-MSDIFF
13769 ENDIF
13770
13771C correct for different MSPAR numbers
13772 IF(MSOFT.NE.MSPAR1) THEN
13773 IF(MSPAR1.GT.1) THEN
13774 XDEL = 0.D0
13775 DO 500 I=MSPAR1+1,MSOFT
13776 XDEL = XDEL+XS1(I)
13777 500 CONTINUE
13778 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13779 DO 550 I=2,MSPAR1
13780 XS1(I) = XS1(I)*XFAC
13781 550 CONTINUE
13782 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13783 ELSE
13784 XSS1 = XSUM1
13785 ENDIF
13786 ENDIF
13787 IF(MSOFT.NE.MSPAR2) THEN
13788 IF(MSPAR2.GT.1) THEN
13789 XDEL = 0.D0
13790 DO 600 I=MSPAR2+1,MSOFT
13791 XDEL = XDEL+XS2(I)
13792 600 CONTINUE
13793 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13794 DO 650 I=2,MSPAR2
13795 XS2(I) = XS2(I)*XFAC
13796 650 CONTINUE
13797 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13798 ELSE
13799 XSS2 = XSUM2
13800 ENDIF
13801 ENDIF
13802
13803C first x entry
13804 XS1(1) = 1.D0 - XSS1
13805 XS2(1) = 1.D0 - XSS2
13806 XSUM1 = XSS1
13807 XSUM2 = XSS2
13808
13809C debug output
13810 IF(IDEB(60).GE.10) THEN
13811 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13812 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13813 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13814 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13815 DO 30 I=1,MSOFT
13816 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13817 & XMIN(1,I),XMIN(2,I)
13818 30 CONTINUE
13819 ENDIF
13820
13821 RETURN
13822
13823C not enough phase space
13824 1000 CONTINUE
13825
13826 IFAIL(42) = IFAIL(42)+1
13827 IREJ = 1
13828
13829C warning message
13830 IF(IDEB(60).GE.1) THEN
13831 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13832 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13833 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13834 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13835 WRITE(LO,'(1X,A,1P,3E11.3)')
13836 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13837 WRITE(LO,'(1X,A,1P,3E11.3)')
13838 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13839 WRITE(LO,'(1X,A,1P,3E11.3)')
13840 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13841 WRITE(LO,'(1X,A)')
13842 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13843 DO 27 I=1,MSOFT
13844 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13845 27 CONTINUE
13846 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13847 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13848 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13849 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13850 DO 25 I=1,MSOFT
13851 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13852 & XMIN(1,I),XMIN(2,I)
13853 25 CONTINUE
13854 ENDIF
13855
13856 END
13857
13858*$ CREATE PHO_SELSXR.FOR
13859*COPY PHO_SELSXR
13860CDECK ID>, PHO_SELSXR
13861 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13862 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13863C***********************************************************************
13864C
13865C select x values of soft string ends (rejection method)
13866C
13867C***********************************************************************
13868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13869 SAVE
13870
13871 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13872
13873C input/output channels
13874 INTEGER LI,LO
13875 COMMON /POINOU/ LI,LO
13876C event debugging information
13877 INTEGER NMAXD
13878 PARAMETER (NMAXD=100)
13879 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13880 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13881 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13882 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13883C model switches and parameters
13884 CHARACTER*8 MDLNA
13885 INTEGER ISWMDL,IPAMDL
13886 DOUBLE PRECISION PARMDL
13887 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13888C data on most recent hard scattering
13889 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13890 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13891 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13892 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13893 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13894 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13895 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13896 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13897 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13898C global event kinematics and particle IDs
13899 INTEGER IFPAP,IFPAB
13900 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13901 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13902C obsolete cut-off information
13903 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13904 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13905
13906 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13907
13908 IF(IDEB(13).GE.10) THEN
13909 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13910 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13911 & MSOFT,XS1,XS2,XMAX1,XMAX2
13912 DO 40 I=1,MSOFT
13913 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13914 40 CONTINUE
13915 ENDIF
13916C
13917 IREJ = 0
13918C
13919 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13920 XMIN1 = MAX(AS/XMAX1,XMINK)
13921 XMIN2 = MAX(AS/XMAX2,XMINK)
13922C
13923 IF(MSOFT.EQ.1) THEN
13924 XSOFT1(2) = 0.D0
13925 XSOFT2(2) = 0.D0
13926 RETURN
13927 ENDIF
13928 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13929 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13930C
13931 10 CONTINUE
13932C
13933 DO 50 I=2,MSOFT
13934 POT(1,I) = XPOT1(I)+1.D0
13935 POT(2,I) = XPOT2(I)+1.D0
13936 REVP(1,I) = 1.D0/POT(1,I)
13937 REVP(2,I) = 1.D0/POT(2,I)
13938 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13939 XLMAX = XMAX1**POT(1,I)
13940 XLDIF(1,I) = XLMAX-XLMIN(1,I)
13941 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13942 XLMAX = XMAX2**POT(2,I)
13943 XLDIF(2,I) = XLMAX-XLMIN(2,I)
13944 50 CONTINUE
13945C
13946 ITRY0 = 0
13947 5 CONTINUE
13948 ITRY0 = ITRY0 + 1
13949 IF(ITRY0.GE.IPAMDL(181)) THEN
13950 IF(MSOFT-MSMIN.GE.2) THEN
13951 MSOFT = MSMIN
13952 GOTO 10
13953 ENDIF
13954 GOTO 1000
13955 ENDIF
13956 XREST1 = 1.D0-XS1
13957 XREST2 = 1.D0-XS2
13958 DO 100 I=2,MSOFT
13959 ITRY1 = 0
13960
13961 20 CONTINUE
13962 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13963 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13964 XSOFT1(I) = Z1**REVP(1,I)
13965 XSOFT2(I) = Z2**REVP(2,I)
13966 ITRY1 = ITRY1+1
13967 IF(ITRY1.GE.50) GOTO 1000
13968 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13969
13970 XREST1 = XREST1-XSOFT1(I)
13971 IF(XREST1.LT.XMIN1) GOTO 5
13972 IF(XREST1.LT.XMIN(1,1)) GOTO 5
13973 XREST2 = XREST2-XSOFT2(I)
13974 IF(XREST2.LT.XMIN2) GOTO 5
13975 IF(XREST2.LT.XMIN(2,1)) GOTO 5
13976 IF(XREST1*XREST2.LT.AS) GOTO 5
13977
13978 100 CONTINUE
13979 XSOFT1(1) = XREST1
13980 XSOFT2(1) = XREST2
13981 IREJ=0
13982* XX = 1.D0
13983* DO 200 I=2,MSOFT
13984* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13985*200 CONTINUE
13986 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13987 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13988
13989 XS1 = 1.D0-XREST1
13990 XS2 = 1.D0-XREST2
13991 RETURN
13992
13993 1000 CONTINUE
13994 IREJ = 1
13995 IF(IDEB(13).GE.2) THEN
13996 WRITE(LO,'(1X,A,2I4)')
13997 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13998 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
13999 ENDIF
14000
14001 END
14002
14003*$ CREATE PHO_SELSX2.FOR
14004*COPY PHO_SELSX2
14005CDECK ID>, PHO_SELSX2
14006 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14007 & XS1,XS2,IREJ)
14008C***********************************************************************
14009C
14010C select x values of soft string ends using PHO_RNDBET
14011C
14012C***********************************************************************
14013 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14014 SAVE
14015
14016 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14017
14018C input/output channels
14019 INTEGER LI,LO
14020 COMMON /POINOU/ LI,LO
14021C event debugging information
14022 INTEGER NMAXD
14023 PARAMETER (NMAXD=100)
14024 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14025 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14026 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14027 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14028C model switches and parameters
14029 CHARACTER*8 MDLNA
14030 INTEGER ISWMDL,IPAMDL
14031 DOUBLE PRECISION PARMDL
14032 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14033C data on most recent hard scattering
14034 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14035 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14036 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14037 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14038 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14039 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14040 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14041 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14042 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14043C obsolete cut-off information
14044 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14045 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14046
14047 IREJ = 0
14048
14049 IF(IDEB(32).GE.10) THEN
14050 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14051 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14052 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14053 DO 30 I=1,2
14054 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14055 30 CONTINUE
14056 ENDIF
14057
14058 FAC1 = 1.D0-XSUM1
14059 FAC2 = 1.D0-XSUM2
14060 FAC = FAC1*FAC2
14061 GAM1 = XPOT1(1)+1.D0
14062 GAM2 = XPOT2(1)+1.D0
14063 BET1 = XPOT1(2)+1.D0
14064 BET2 = XPOT2(2)+1.D0
14065
14066 ITRY0 = 0
14067 DO 100 I=1,IPAMDL(182)
14068
14069 ITRY1 = 0
14070 10 CONTINUE
14071 X1 = PHO_RNDBET(GAM1,BET1)
14072 ITRY1 = ITRY1+1
14073 IF(ITRY1.GE.50) GOTO 1000
14074 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14075
14076 ITRY2 = 0
14077 11 CONTINUE
14078 X2 = PHO_RNDBET(GAM2,BET2)
14079 ITRY2 = ITRY2+1
14080 IF(ITRY2.GE.50) GOTO 1000
14081 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14082
14083 X3 = 1.D0 - X1
14084 X4 = 1.D0 - X2
14085 IF(X1*X2*FAC.GT.AS) THEN
14086 IF(X3*X4*FAC.GT.AS) THEN
14087 XS1(1) = X1*FAC1
14088 XS1(2) = X3*FAC1
14089 XS2(1) = X2*FAC2
14090 XS2(2) = X4*FAC2
14091 IF(XS1(1).GT.XMIN(1,1)) THEN
14092 IF(XS2(1).GT.XMIN(2,1)) THEN
14093 IF(XS1(2).GT.XMIN(1,2)) THEN
14094 IF(XS2(2).GT.XMIN(2,2)) THEN
14095 XSUM1 = XSUM1+XS1(2)
14096 XSUM2 = XSUM2+XS2(2)
14097 GOTO 300
14098 ENDIF
14099 ENDIF
14100 ENDIF
14101 ENDIF
14102 ENDIF
14103 ENDIF
14104 ITRY0 = ITRY0+1
14105
14106 100 CONTINUE
14107
14108 1000 CONTINUE
14109 IREJ = 1
14110 IF(IDEB(32).GE.2) THEN
14111 WRITE(LO,'(1X,A,3I4)')
14112 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14113 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14114 ENDIF
14115 RETURN
14116 300 CONTINUE
14117
14118 END
14119
14120*$ CREATE PHO_SELSXS.FOR
14121*COPY PHO_SELSXS
14122CDECK ID>, PHO_SELSXS
14123 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14124 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14125C***********************************************************************
14126C
14127C select x values of soft string ends (rescaling method)
14128C
14129C***********************************************************************
14130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14131 SAVE
14132
14133 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14134
14135C input/output channels
14136 INTEGER LI,LO
14137 COMMON /POINOU/ LI,LO
14138C event debugging information
14139 INTEGER NMAXD
14140 PARAMETER (NMAXD=100)
14141 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14142 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14143 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14144 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14145C model switches and parameters
14146 CHARACTER*8 MDLNA
14147 INTEGER ISWMDL,IPAMDL
14148 DOUBLE PRECISION PARMDL
14149 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14150C data on most recent hard scattering
14151 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14152 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14153 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14154 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14155 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14156 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14157 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14158 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14159 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14160C obsolete cut-off information
14161 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14162 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14163
14164 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14165
14166 IREJ = 0
14167
14168 10 CONTINUE
14169
14170 IF(MSOFT.EQ.1) THEN
14171 XSOFT1(1) = 1.D0-XS1
14172 XSOFT1(2) = 0.D0
14173 XSOFT2(1) = 1.D0-XS2
14174 XSOFT2(2) = 0.D0
14175 RETURN
14176 ENDIF
14177
14178 DO 50 I=1,MSOFT
14179 POT(1,I) = XPOT1(I)+1.D0
14180 POT(2,I) = XPOT2(I)+1.D0
14181 REVP(1,I) = 1.D0/POT(1,I)
14182 REVP(2,I) = 1.D0/POT(2,I)
14183 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14184 XLMAX = XMAX1**POT(1,I)
14185 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14186 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14187 XLMAX = XMAX2**POT(2,I)
14188 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14189 50 CONTINUE
14190
14191 ITRY0 = 0
14192 5 CONTINUE
14193 ITRY0 = ITRY0 + 1
14194 IF(ITRY0.GE.IPAMDL(180)) THEN
14195 IF(MSOFT-MSMIN.GE.2) THEN
14196 MSOFT= MSMIN
14197 GOTO 10
14198 ENDIF
14199 GOTO 1000
14200 ENDIF
14201 XSUM1 = 0.D0
14202 XSUM2 = 0.D0
14203 DO 100 I=1,MSOFT
14204 ITRY1 = 0
14205 20 CONTINUE
14206 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14207 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14208 XSOFT1(I) = Z1**REVP(1,I)
14209 XSOFT2(I) = Z2**REVP(2,I)
14210 ITRY1 = ITRY1+1
14211 IF(ITRY1.GE.50) GOTO 1000
14212 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14213 XSUM1 = XSUM1+XSOFT1(I)
14214 XSUM2 = XSUM2+XSOFT2(I)
14215 100 CONTINUE
14216 FAC1 = (1.D0-XS1)/XSUM1
14217 FAC2 = (1.D0-XS2)/XSUM2
14218 DO 200 I=1,MSOFT
14219 XSOFT1(I) = XSOFT1(I)*FAC1
14220 XSOFT2(I) = XSOFT2(I)*FAC2
14221 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14222 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14223 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14224 200 CONTINUE
14225
14226 XS1 = 1.D0-XSOFT1(1)
14227 XS2 = 1.D0-XSOFT2(1)
14228 RETURN
14229
14230 1000 CONTINUE
14231 IREJ = 1
14232 IF(IDEB(14).GE.2) THEN
14233 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14234 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14235 DO 300 I=1,MSOFT
14236 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14237 300 CONTINUE
14238 ENDIF
14239
14240 END
14241
14242*$ CREATE PHO_SELSXI.FOR
14243*COPY PHO_SELSXI
14244CDECK ID>, PHO_SELSXI
14245 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14246 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14247C***********************************************************************
14248C
14249C select x values of soft string ends (sea independent from valence)
14250C
14251C***********************************************************************
14252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14253 SAVE
14254
14255 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14256
14257C input/output channels
14258 INTEGER LI,LO
14259 COMMON /POINOU/ LI,LO
14260C event debugging information
14261 INTEGER NMAXD
14262 PARAMETER (NMAXD=100)
14263 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14264 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14265 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14266 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14267C model switches and parameters
14268 CHARACTER*8 MDLNA
14269 INTEGER ISWMDL,IPAMDL
14270 DOUBLE PRECISION PARMDL
14271 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14272C data on most recent hard scattering
14273 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14274 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14275 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14276 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14277 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14278 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14279 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14280 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14281 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14282C obsolete cut-off information
14283 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14284 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14285
14286 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14287
14288 IREJ = 0
14289
14290 10 CONTINUE
14291
14292 DO 50 I=1,MSOFT
14293 POT(1,I) = XPOT1(I)+1.D0
14294 POT(2,I) = XPOT2(I)+1.D0
14295 REVP(1,I) = 1.D0/POT(1,I)
14296 REVP(2,I) = 1.D0/POT(2,I)
14297 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14298 XLMAX = XMAX1**POT(1,I)
14299 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14300 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14301 XLMAX = XMAX2**POT(2,I)
14302 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14303 50 CONTINUE
14304
14305C selection of sea
14306 ITRY0 = 0
14307 5 CONTINUE
14308
14309 ITRY0 = ITRY0 + 1
14310 IF(ITRY0.GE.IPAMDL(183)) THEN
14311 IF(MSOFT-MSMIN.GE.2) THEN
14312 MSOFT = MSMIN
14313 GOTO 10
14314 ENDIF
14315 GOTO 1000
14316 ENDIF
14317 XSUM1 = XS1
14318 XSUM2 = XS2
14319 DO 100 I=3,MSOFT
14320 ITRY1 = 0
14321 20 CONTINUE
14322 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14323 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14324 XSOFT1(I) = Z1**REVP(1,I)
14325 XSOFT2(I) = Z2**REVP(2,I)
14326 ITRY1 = ITRY1+1
14327 IF(ITRY1.GE.50) GOTO 1000
14328 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14329 XSUM1 = XSUM1+XSOFT1(I)
14330 XSUM2 = XSUM2+XSOFT2(I)
14331 100 CONTINUE
14332
14333 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14334 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14335
14336C selection of valence
14337 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14338 & XSOFT1,XSOFT2,IREJ)
14339 IF(IREJ.NE.0) THEN
14340 IF(MSOFT-MSMIN.GE.2) THEN
14341 MSOFT = MSMIN
14342 GOTO 10
14343 ENDIF
14344 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14345 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14346 & XSUM1,XSUM2,XMAX1,XMAX2
14347 RETURN
14348 ENDIF
14349
14350 XS1 = 1.D0-XSOFT1(1)
14351 XS2 = 1.D0-XSOFT2(1)
14352 RETURN
14353
14354 1000 CONTINUE
14355 IREJ = 1
14356 IF(IDEB(14).GE.2) THEN
14357 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14358 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14359 DO 300 I=1,MSOFT
14360 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14361 300 CONTINUE
14362 ENDIF
14363
14364 END
14365
14366*$ CREATE PHO_SELCOL.FOR
14367*COPY PHO_SELCOL
14368CDECK ID>, PHO_SELCOL
14369 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370C********************************************************************
14371C
14372C color combinatorics
14373C
14374C input: ICO1,2 colors of incoming particle
14375C IMODE -2 output of initialization status
14376C -1 initialization
14377C ICINP(1) selection mode
14378C 0 QCD
14379C 1 large N_c expansion
14380C ICINP(2) max. allowed color
14381C 0 clear internal color counter
14382C 1 hadron into two colored objects
14383C 2 quark into quark gluon
14384C 3 gluon into gluon gluon
14385C 4 gluon into quark antiquark
14386C
14387C output: ICOA1,2 colors of first outgoing particle
14388C ICOB1,2 colors of second outgoing particle
14389C
14390C********************************************************************
14391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14392 SAVE
14393
14394C input/output channels
14395 INTEGER LI,LO
14396 COMMON /POINOU/ LI,LO
14397C event debugging information
14398 INTEGER NMAXD
14399 PARAMETER (NMAXD=100)
14400 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14401 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14402 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14403 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14404
14405 DATA METHOD /0/, II /0/
14406
14407 ICI1 = ICO1
14408 ICI2 = ICO2
14409 IF(METHOD.EQ.0) THEN
14410
14411 IF(IMODE.EQ.1) THEN
14412 II = II+1
14413 IF(II.GT.MAXCOL)
14414 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415 ICOA1 = II
14416 ICOA2 = 0
14417 ICOB1 = -II
14418 ICOB2 = 0
14419 ELSE IF(IMODE.EQ.2) THEN
14420 II = II+1
14421 IF(II.GT.MAXCOL)
14422 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14423 ICOA2 = 0
14424 IF(ICI1.GT.0) THEN
14425 ICOA1 = II
14426 ICOB1 = ICI1
14427 ICOB2 = -II
14428 ELSE
14429 ICOA1 = -II
14430 ICOB1 = II
14431 ICOB2 = ICI1
14432 ENDIF
14433 ELSE IF(IMODE.EQ.3) THEN
14434 II = II+1
14435 IF(II.GT.MAXCOL)
14436 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14437 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14438 ICOA1 = ICI1
14439 ICOA2 = -II
14440 ICOB1 = II
14441 ICOB2 = ICI2
14442 ELSE
14443 ICOB1 = ICI1
14444 ICOB2 = -II
14445 ICOA1 = II
14446 ICOA2 = ICI2
14447 ENDIF
14448 ELSE IF(IMODE.EQ.4) THEN
14449 ICOA1 = ICI1
14450 ICOA2 = 0
14451 ICOB1 = ICI2
14452 ICOB2 = 0
14453 ELSE IF(IMODE.EQ.0) THEN
14454 II = 0
14455 ELSE IF(IMODE.EQ.-1) THEN
14456 METHOD = ICI1
14457 MAXCOL = ICI2
14458 ELSE IF(IMODE.EQ.-2) THEN
14459 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14460 & METHOD,MAXCOL
14461 ELSE
14462 WRITE(LO,'(1X,A,I5)')
14463 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14464 CALL PHO_ABORT
14465 ENDIF
14466
14467 ELSE
14468 WRITE(LO,'(1X,A,I5)')
14469 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14470 CALL PHO_ABORT
14471 ENDIF
14472
14473 II = ABS(II)
14474 IF(IDEB(75).GE.10) THEN
14475 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14476 & IMODE,MAXCOL,II
14477 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14478 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14479 ENDIF
14480
14481 END
14482
14483*$ CREATE ipho_diqu.FOR
14484*COPY ipho_diqu
14485CDECK ID>, ipho_diqu
14486 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14487C***********************************************************************
14488C
14489C selection of diquark number (PDG convention)
14490C
14491C***********************************************************************
14492 IMPLICIT NONE
14493 SAVE
14494
14495 integer iq1,iq2
14496
14497C input/output channels
14498 INTEGER LI,LO
14499 COMMON /POINOU/ LI,LO
14500C event debugging information
14501 INTEGER NMAXD
14502 PARAMETER (NMAXD=100)
14503 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14504 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14505 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14506 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14507C model switches and parameters
14508 CHARACTER*8 MDLNA
14509 INTEGER ISWMDL,IPAMDL
14510 DOUBLE PRECISION PARMDL
14511 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14512
14513C external functions
14514 double precision DT_RNDM
14515
14516C local variables
14517 integer i0,i1,i2
14518 double precision dum
14519
14520 i1 = abs(iq1)
14521 i2 = abs(iq2)
14522
14523 if(i1.eq.i2) then
14524 i0 = i1*1100+3
14525 else
14526 i0 = max(i1,i2)*1000+min(i1,i2)*100
14527 if(DT_RNDM(dum).gt.PARMDL(135)) then
14528 i0 = i0+1
14529 else
14530 i0 = i0+3
14531 endif
14532 endif
14533
14534 ipho_diqu = sign(i0,iq1)
14535
14536 END
14537
14538*$ CREATE PHO_PARREM.FOR
14539*COPY PHO_PARREM
14540CDECK ID>, PHO_PARREM
14541 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14542C**********************************************************************
14543C
14544C selection of particle remnant flavour(s) (quark or diquark)
14545C
14546C input: INDX index of particle in /POEVT1/
14547C IOUT parton which was taken out
14548C
14549C output: IREM remnant according to valence flavours
14550C IREJ 0 flavour combination possible
14551C 1 flavour combination impossible
14552C
14553C all particle ID are given according to PDG conventions
14554C
14555C**********************************************************************
14556 IMPLICIT NONE
14557 SAVE
14558
14559 integer INDX,IOUT,IREM,IREJ
14560
14561C input/output channels
14562 INTEGER LI,LO
14563 COMMON /POINOU/ LI,LO
14564C event debugging information
14565 INTEGER NMAXD
14566 PARAMETER (NMAXD=100)
14567 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14568 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14569 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14570 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14571C standard particle data interface
14572 INTEGER NMXHEP
14573 PARAMETER (NMXHEP=4000)
14574 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14575 DOUBLE PRECISION PHEP,VHEP
14576 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14577 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14578 & VHEP(4,NMXHEP)
14579C extension to standard particle data interface (PHOJET specific)
14580 INTEGER IMPART,IPHIST,ICOLOR
14581 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14582C general particle data
14583 double precision xm_list,tau_list,gam_list,
14584 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14585 & xm_bb82_list,xm_bb102_list
14586 integer ich3_list,iba3_list,iq_list,
14587 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14588 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14589 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14590 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14591 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14592 & ich3_list(300),iba3_list(300),iq_list(3,300),
14593 & id_psm_list(6,6),id_vem_list(6,6),
14594 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14595
14596C external functions
14597 integer ipho_diqu
14598
14599C local variables
14600 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14601 dimension IQUA(3),IDQ(2)
14602
14603 ID1 = IDHEP(INDX)
14604 ID2 = IMPART(INDX)
14605 IREJ = 0
14606
14607 IF(ID2.EQ.0) THEN
14608 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14609 CALL PHO_ABORT
14610 ENDIF
14611
14612C particle with flavour mixing
14613 if(ID1.eq.22) then
14614C photon
14615 IREM = -IOUT
14616 GOTO 100
14617 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14618C pi0, rho0, and omega
14619 IF(ABS(IOUT).LE.2) THEN
14620 IREM = -IOUT
14621 GOTO 100
14622 ELSE
14623 GOTO 150
14624 ENDIF
14625 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14626C neutral kaons (K0,K0-bar)
14627 if(abs(IOUT).eq.1) then
14628 IREM = sign(3,-IOUT)
14629 goto 100
14630 else if(abs(IOUT).eq.3) then
14631 IREM = sign(1,-IOUT)
14632 goto 100
14633 else
14634 goto 150
14635 endif
14636 else if((ID1.eq.990).or.(ID1.eq.110)) then
14637C pomeron and reggeon
14638 IREM = -IOUT
14639 GOTO 100
14640 endif
14641
14642C ordinary hadron
14643 ID = abs(ID2)
14644 IS = sign(1,ID2)
14645 IQUA(1) = iq_list(1,ID)*IS
14646 IQUA(2) = iq_list(2,ID)*IS
14647 IQUA(3) = iq_list(3,ID)*IS
14648
14649C compare to flavour content
14650 IF(ABS(IOUT).LT.1000) THEN
14651C single quark requested
14652 IF(IQUA(1).EQ.IOUT) THEN
14653 K1 = 2
14654 K2 = 3
14655 ELSE IF(IQUA(2).EQ.IOUT) THEN
14656 K1 = 1
14657 K2 = 3
14658 ELSE IF(IQUA(3).EQ.IOUT) THEN
14659 K1 = 1
14660 K2 = 2
14661 ELSE
14662 GOTO 150
14663 ENDIF
14664 IF(IQUA(3).EQ.0) THEN
14665 IREM = IQUA(K1)
14666 ELSE
14667 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14668 ENDIF
14669 ELSE IF(IQUA(3).NE.0) THEN
14670C diquark requested from baryon
14671 IDQ(1) = IOUT/1000
14672 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14673 do i=1,2
14674 do k=1,3
14675 if(IDQ(i).eq.IQUA(k)) then
14676 IQUA(k) = 0
14677 goto 110
14678 endif
14679 enddo
14680 goto 150
14681 110 continue
14682 enddo
14683 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14684 ENDIF
14685
14686 100 CONTINUE
14687C debug output
14688 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14689 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14690 & INDX,ID1,ID2,IOUT,IREM
14691 RETURN
14692
14693C rejection
14694 150 CONTINUE
14695 IREJ = 1
14696 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14697 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14698
14699 END
14700
14701*$ CREATE PHO_VALFLA.FOR
14702*COPY PHO_VALFLA
14703CDECK ID>, PHO_VALFLA
14704 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14705C***********************************************************************
14706C
14707C selection of valence flavour decomposition of particle IPAR
14708C
14709C input: IPAR particle index in /POEVT1/
14710C -1 initialization
14711C -2 output of statistics
14712C XMASS mass of particle
14713C (important for pomeron:
14714C mass dependent flavour sampling)
14715C
14716C output: IFL1,IFL2
14717C baryon: IFL1 diquark flavour
14718C (valence flavours according to PDG conventions)
14719C
14720C***********************************************************************
14721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14722 SAVE
14723
14724 PARAMETER ( EPS = 0.1D0,
14725 & DEPS = 1.D-15)
14726
14727C input/output channels
14728 INTEGER LI,LO
14729 COMMON /POINOU/ LI,LO
14730C event debugging information
14731 INTEGER NMAXD
14732 PARAMETER (NMAXD=100)
14733 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14734 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14735 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14736 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14737C model switches and parameters
14738 CHARACTER*8 MDLNA
14739 INTEGER ISWMDL,IPAMDL
14740 DOUBLE PRECISION PARMDL
14741 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14742C standard particle data interface
14743 INTEGER NMXHEP
14744 PARAMETER (NMXHEP=4000)
14745 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14746 DOUBLE PRECISION PHEP,VHEP
14747 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14748 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14749 & VHEP(4,NMXHEP)
14750C extension to standard particle data interface (PHOJET specific)
14751 INTEGER IMPART,IPHIST,ICOLOR
14752 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14753C general particle data
14754 double precision xm_list,tau_list,gam_list,
14755 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14756 & xm_bb82_list,xm_bb102_list
14757 integer ich3_list,iba3_list,iq_list,
14758 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14759 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14760 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14761 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14762 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14763 & ich3_list(300),iba3_list(300),iq_list(3,300),
14764 & id_psm_list(6,6),id_vem_list(6,6),
14765 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14766
14767 data ITMX / 5 /
14768
14769 IF(IPAR.GT.0) THEN
14770 K = IPAR
14771C select particle code
14772 ID1 = IDHEP(K)
14773 ID = abs(IMPART(K))
14774 IBAR = IPHO_BAR3(K,2)
14775 ITER = 0
14776
14777 10 CONTINUE
14778
14779 ifl1 = 0
14780 ifl2 = 0
14781 ITER = ITER+1
14782 if(ITER.GT.ITMX) then
14783 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14784 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14785 return
14786 endif
14787
14788C not baryon
14789 IF(IBAR.EQ.0) THEN
14790
14791C photon
14792 IF(ID1.EQ.22) THEN
14793C charge dependent flavour sampling
14794 15 CONTINUE
14795 K = INT(DT_RNDM(E1)*6.D0)+1
14796 IF(K.LE.4) THEN
14797 IFL1 = 2
14798 IFL2 = -2
14799 ELSE IF(K.EQ.5) THEN
14800 IFL1 = 1
14801 IFL2 = -1
14802 ELSE
14803 IFL1 = 3
14804 IFL2 = -3
14805 ENDIF
14806C optional strangeness suppression
14807 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14808 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14809 K = IFL1
14810 IFL1 = IFL2
14811 IFL2 = K
14812 ENDIF
14813
14814C pomeron, reggeon
14815 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14816 IF(ISWMDL(19).EQ.0) THEN
14817C SU(3) symmetric valences
14818 K = INT(DT_RNDM(E1)*3.D0)+1
14819 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14820 IFL1 = K
14821 ELSE
14822 IFL1 = -K
14823 ENDIF
14824 IFL2 = -IFL1
14825 ELSE IF(ISWMDL(19).EQ.1) THEN
14826C mass dependent flavour sampling
14827 EMIN = MIN(E1,E2)
14828 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14829 ELSE
14830 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14831 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14832 CALL PHO_ABORT
14833 ENDIF
14834
14835C meson with flavour mixing
14836 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14837 K = INT(2.D0*DT_RNDM(E1))+1
14838 IFL1 = K
14839 IFL2 = -K
14840C meson (standard)
14841 ELSE
14842 K = INT(2.D0*DT_RNDM(E1))+1
14843 IFL1 = iq_list(K,ID)
14844 K = MOD(K,2) + 1
14845 IFL2 = iq_list(K,ID)
14846 if(IFL1.EQ.0) then
14847 EMIN = MIN(E1,E2)
14848 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14849 endif
14850 ENDIF
14851
14852C baryon
14853 ELSE
14854 K = INT(2.999999D0*DT_RNDM(E2))+1
14855 K1 = MOD(K,3)+1
14856 K2 = MOD(K1,3)+1
14857 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14858 IFL2 = iq_list(K,ID)
14859 ENDIF
14860
14861C change sign for antiparticles
14862 if(ID1.lt.0) then
14863 IFL1 = -IFL1
14864 IFL2 = -IFL2
14865 endif
14866
14867************************************************************************
14868C check kinematic constraints
14869* IF((PHO_PMASS(IFL1,3).GT.E1)
14870* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14871************************************************************************
14872
14873C debug output
14874 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14875 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14876
14877 ELSE IF(IPAR.EQ.-1) THEN
14878C initialization
14879
14880 ELSE IF(IPAR.EQ.-2) THEN
14881C output of final statistics
14882
14883 ELSE
14884 WRITE(LO,'(1X,A,I10)')
14885 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14886 CALL PHO_ABORT
14887 ENDIF
14888
14889 END
14890
14891*$ CREATE PHO_REGFLA.FOR
14892*COPY PHO_REGFLA
14893CDECK ID>, PHO_REGFLA
14894 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14895C**********************************************************************
14896C
14897C selection of reggeon flavours
14898C
14899C input: JM1,JM2 position index of mother hadrons
14900C
14901C output: IFLR1,IFLR2 valence flavours according to
14902C PDG conventions and JM1,JM2
14903C IREJ 0 reggeon possible
14904C 1 reggeon impossible
14905C
14906C**********************************************************************
14907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14908 SAVE
14909
14910 PARAMETER ( EPS = 0.1D0,
14911 & DEPS = 1.D-15)
14912
14913C input/output channels
14914 INTEGER LI,LO
14915 COMMON /POINOU/ LI,LO
14916C event debugging information
14917 INTEGER NMAXD
14918 PARAMETER (NMAXD=100)
14919 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14920 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14921 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14922 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14923C nucleon-nucleus / nucleus-nucleus interface to DPMJET
14924 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14925 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14926 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14927 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14928C standard particle data interface
14929 INTEGER NMXHEP
14930 PARAMETER (NMXHEP=4000)
14931 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14932 DOUBLE PRECISION PHEP,VHEP
14933 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14934 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14935 & VHEP(4,NMXHEP)
14936C extension to standard particle data interface (PHOJET specific)
14937 INTEGER IMPART,IPHIST,ICOLOR
14938 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14939
14940 IF(JM1.GT.0) THEN
14941 IREJ = 0
14942 ITER = 0
14943C available energy
14944 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14945 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
14946 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
14947 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14948 50 CONTINUE
14949 ITER = ITER+1
14950 IF(ITER.GT.50) THEN
14951 IREJ = 1
14952C debug output
14953 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14954 & 'PHO_REGFLA: rejection, no reggeon found for',
14955 & IDHEP(JM1),IDHEP(JM2),E1
14956 RETURN
14957 ENDIF
14958
14959 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14960 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14961 IF(IFLA1.EQ.-IFLB1) THEN
14962 IFLR1 = IFLA2
14963 IFLR2 = IFLB2
14964 ELSE IF(IFLA1.EQ.-IFLB2) THEN
14965 IFLR1 = IFLA2
14966 IFLR2 = IFLB1
14967 ELSE IF(IFLA2.EQ.-IFLB1) THEN
14968 IFLR1 = IFLA1
14969 IFLR2 = IFLB2
14970 ELSE IF(IFLA2.EQ.-IFLB2) THEN
14971 IFLR1 = IFLA1
14972 IFLR2 = IFLB1
14973 ELSE
14974C debug output
14975 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14976 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14977 GOTO 50
14978 ENDIF
14979C debug output
14980 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14981 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14982 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14983 ELSE IF(JM1.EQ.-1) THEN
14984C initialization
14985 ELSE IF(JM1.EQ.-2) THEN
14986C output of statistics
14987 ELSE
14988 WRITE(LO,'(1X,A,I10)')
14989 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
14990 CALL PHO_ABORT
14991 ENDIF
14992
14993 END
14994
14995*$ CREATE PHO_SEAFLA.FOR
14996*COPY PHO_SEAFLA
14997CDECK ID>, PHO_SEAFLA
14998 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14999C**********************************************************************
15000C
15001C selection of sea flavour content of particle IPAR
15002C
15003C input: IPAR particle index in /POEVT1/
15004C CHMASS available invariant string mass
15005C positive mass --> use BAMJET method
15006C negative mass --> SU(3) symmetric sea according
15007C to values given in PARMDL(1-6)
15008C IPAR -1 initialization
15009C -2 output of statistics
15010C
15011C output: sea flavours according to PDG conventions
15012C
15013C**********************************************************************
15014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15015 SAVE
15016
15017 PARAMETER ( EPS = 0.1D0,
15018 & DEPS = 1.D-15)
15019
15020C input/output channels
15021 INTEGER LI,LO
15022 COMMON /POINOU/ LI,LO
15023C event debugging information
15024 INTEGER NMAXD
15025 PARAMETER (NMAXD=100)
15026 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15027 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15028 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15029 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15030C model switches and parameters
15031 CHARACTER*8 MDLNA
15032 INTEGER ISWMDL,IPAMDL
15033 DOUBLE PRECISION PARMDL
15034 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15035C some hadron information, will be deleted in future versions
15036 INTEGER NFS
15037 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15038 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15039
15040 IF(IPAR.GT.0) THEN
15041 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15042C constant weights for sea
15043 15 CONTINUE
15044 SUM = 0.D0
15045 DO 40 K=1,NFSEA
15046 SUM = SUM + PARMDL(K)
15047 40 CONTINUE
15048 XI = DT_RNDM(SUM)*SUM
15049 SUM = 0.D0
15050 DO 50 K=1,NFSEA
15051 SUM = SUM + PARMDL(K)
15052 IF(XI.LE.SUM) GOTO 55
15053 50 CONTINUE
15054 55 CONTINUE
15055 IF(K.GT.NFSEA) GOTO 15
15056 ELSE
15057C mass dependent flavour sampling
15058 10 CONTINUE
15059 CALL PHO_FLAUX(CHMASS,K)
15060 IF(K.GT.NFSEA) GOTO 10
15061 ENDIF
15062 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15063 IFL1 = K
15064 IFL2 = -K
15065 IF(IDEB(46).GE.10) THEN
15066 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15067 & IPAR,IFL1,IFL2,CHMASS
15068 ENDIF
15069 ELSE IF(IPAR.EQ.-1) THEN
15070C initialization
15071 NFSEA = NFS
15072 ELSE IF(IPAR.EQ.-2) THEN
15073C output of statistics
15074 ELSE
15075 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15076 CALL PHO_ABORT
15077 ENDIF
15078
15079 END
15080
15081*$ CREATE PHO_FLAUX.FOR
15082*COPY PHO_FLAUX
15083CDECK ID>, PHO_FLAUX
15084 SUBROUTINE PHO_FLAUX(EQUARK,K)
15085C***********************************************************************
15086C
15087C auxiliary subroutine to select flavours
15088C
15089C********************************************************************
15090 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15091 SAVE
15092
15093 PARAMETER ( DEPS = 1.D-14 )
15094
15095C input/output channels
15096 INTEGER LI,LO
15097 COMMON /POINOU/ LI,LO
15098C event debugging information
15099 INTEGER NMAXD
15100 PARAMETER (NMAXD=100)
15101 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15102 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15103 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15104 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15105C some hadron information, will be deleted in future versions
15106 INTEGER NFS
15107 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15108 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15109
15110 DIMENSION WGHT(9)
15111
15112C calculate weights for given energy
15113 IF(EQUARK.LT.QMASS(1)) THEN
15114 IF(IDEB(16).GE.5)
15115 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15116 & EQUARK
15117 WGHT(1) = 0.5D0
15118 WGHT(2) = 0.5D0
15119 WGHT(3) = 0.D0
15120 WGHT(4) = 0.D0
15121 SUM = 1.D0
15122 ELSE
15123 SUM = 0.D0
15124 DO 305 K=1,NFS
15125 IF(EQUARK.GT.QMASS(K)) THEN
15126 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15127 ELSE
15128 WGHT(K) = 0.D0
15129 ENDIF
15130 SUM = SUM + WGHT(K)
15131 305 CONTINUE
15132 ENDIF
15133C sample flavours
15134 XI = SUM*(DT_RNDM(SUM)-DEPS)
15135 K = 0
15136 SUM = 0.D0
15137 400 CONTINUE
15138 K = K+1
15139 SUM = SUM + WGHT(K)
15140 IF(XI.GT.SUM) GOTO 400
15141C debug output
15142 IF(IDEB(16).GE.20) THEN
15143 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15144 ENDIF
15145 END
15146
15147*$ CREATE PHO_BETAF.FOR
15148*COPY PHO_BETAF
15149CDECK ID>, PHO_BETAF
15150 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15151C********************************************************************
15152C
15153C weights of different quark flavours
15154C
15155C********************************************************************
15156 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15157 SAVE
15158
15159 AX=0.D0
15160 BETX1=BET*X1
15161 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15162 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15163
15164 PHO_BETAF=AX+AY
15165
15166 END
15167
15168*$ CREATE PHO_MCHECK.FOR
15169*COPY PHO_MCHECK
15170CDECK ID>, PHO_MCHECK
15171 SUBROUTINE PHO_MCHECK(J1,IREJ)
15172C********************************************************************
15173C
15174C check parton momenta for fragmentation
15175C
15176C input: J1 first string number
15177C /POEVT1/
15178C /POSTRG/
15179C
15180C output: /POEVT1/
15181C /POSTRG/
15182C IREJ 0 successful
15183C 1 failure
15184C
15185C in case of very small string mass:
15186C NNCH mass label of string
15187C 0 string
15188C -1 octett baryon / pseudo scalar meson
15189C 1 decuplett baryon / vector meson
15190C IBHAD hadron number according to CPC,
15191C string will be treated as resonance
15192C (sometimes far off mass shell)
15193C
15194C constant WIDTH ( 0.01GeV ) determines range of acceptance
15195C
15196C********************************************************************
15197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15198 SAVE
15199
15200 PARAMETER ( WIDTH = 0.01D0,
15201 & DEPS = 1.D-15 )
15202
15203C input/output channels
15204 INTEGER LI,LO
15205 COMMON /POINOU/ LI,LO
15206C event debugging information
15207 INTEGER NMAXD
15208 PARAMETER (NMAXD=100)
15209 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15210 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15211 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15212 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15213C model switches and parameters
15214 CHARACTER*8 MDLNA
15215 INTEGER ISWMDL,IPAMDL
15216 DOUBLE PRECISION PARMDL
15217 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15218C standard particle data interface
15219 INTEGER NMXHEP
15220 PARAMETER (NMXHEP=4000)
15221 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15222 DOUBLE PRECISION PHEP,VHEP
15223 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15224 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15225 & VHEP(4,NMXHEP)
15226C extension to standard particle data interface (PHOJET specific)
15227 INTEGER IMPART,IPHIST,ICOLOR
15228 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15229C color string configurations including collapsed strings and hadrons
15230 INTEGER MSTR
15231 PARAMETER (MSTR=500)
15232 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15233 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15234 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15235 & NNCH(MSTR),IBHAD(MSTR),ISTR
15236C internal rejection counters
15237 INTEGER NMXJ
15238 PARAMETER (NMXJ=60)
15239 CHARACTER*10 REJTIT
15240 INTEGER IFAIL
15241 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15242
15243 IREJ = 0
15244C quark antiquark jet
15245 STRM = PHEP(5,NPOS(1,J1))
15246 IF(NCODE(J1).EQ.3) THEN
15247 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15248 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15249 IF(IDEB(18).GE.5)
15250 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15251 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15252 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15253 IF(STRM.LT.AMPS) THEN
15254 IREJ = 1
15255 IFAIL(20) = IFAIL(20) + 1
15256 RETURN
15257 ELSE IF(STRM.LT.AMPS2) THEN
15258 IF(STRM.LT.(AMVE-WIDTH)) THEN
15259 NNCH(J1) = -1
15260 IBHAD(J1) = IPS
15261 ELSE
15262 NNCH(J1) = 1
15263 IBHAD(J1) = IVE
15264 ENDIF
15265 ELSE
15266 NNCH(J1) = 0
15267 IBHAD(J1) = 0
15268 ENDIF
15269C quark diquark or v.s. jet
15270 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15271 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15272 & AM8,AM82,AM10,AM102,I8,I10)
15273 IF(IDEB(18).GE.5)
15274 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15275 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15276 & J1,STRM,AM8,AM82,AM10,AM102
15277 IF(STRM.LT.AM8) THEN
15278 IREJ = 1
15279 IFAIL(19) = IFAIL(19) + 1
15280 RETURN
15281 ELSE IF(STRM.LT.AM82) THEN
15282 IF(STRM.LT.(AM10-WIDTH)) THEN
15283 NNCH(J1) = -1
15284 IBHAD(J1) = I8
15285 ELSE
15286 NNCH(J1) = 1
15287 IBHAD(J1) = I10
15288 ENDIF
15289 ELSE
15290 NNCH(J1) = 0
15291 IBHAD(J1) = 0
15292 ENDIF
15293C diquark a-diquark string
15294 ELSE IF(NCODE(J1).EQ.5) THEN
15295 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15296 & AM82,AM102)
15297 IF(IDEB(18).GE.5)
15298 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15299 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15300 & J1,STRM,AM82,AM102
15301 IF(STRM.LT.AM82) THEN
15302 IREJ = 1
15303 IFAIL(19) = IFAIL(19) + 1
15304 RETURN
15305 ELSE
15306 NNCH(J1) = 0
15307 IBHAD(J1) = 0
15308 ENDIF
15309 ELSE IF(NCODE(J1).LT.0) THEN
15310 RETURN
15311 ELSE
15312 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15313 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15314 CALL PHO_ABORT
15315 ENDIF
15316 END
15317
15318*$ CREATE PHO_POMCOR.FOR
15319*COPY PHO_POMCOR
15320CDECK ID>, PHO_POMCOR
15321 SUBROUTINE PHO_POMCOR(IREJ)
15322C********************************************************************
15323C
15324C join quarks to gluons in case of too small masses
15325C
15326C input: /POEVT1/
15327C /POSTRG/
15328C IREJ -1 initialization
15329C -2 output of statistics
15330C
15331C output: /POEVT1/
15332C /POSTRG/
15333C IREJ 0 successful
15334C 1 failure
15335C
15336C
15337C********************************************************************
15338 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15339 SAVE
15340
15341 PARAMETER ( EPS = 1.D-10 )
15342
15343C input/output channels
15344 INTEGER LI,LO
15345 COMMON /POINOU/ LI,LO
15346C event debugging information
15347 INTEGER NMAXD
15348 PARAMETER (NMAXD=100)
15349 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15350 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15351 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15352 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15353C model switches and parameters
15354 CHARACTER*8 MDLNA
15355 INTEGER ISWMDL,IPAMDL
15356 DOUBLE PRECISION PARMDL
15357 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15358C standard particle data interface
15359 INTEGER NMXHEP
15360 PARAMETER (NMXHEP=4000)
15361 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15362 DOUBLE PRECISION PHEP,VHEP
15363 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15364 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15365 & VHEP(4,NMXHEP)
15366C extension to standard particle data interface (PHOJET specific)
15367 INTEGER IMPART,IPHIST,ICOLOR
15368 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15369C color string configurations including collapsed strings and hadrons
15370 INTEGER MSTR
15371 PARAMETER (MSTR=500)
15372 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15373 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15374 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15375 & NNCH(MSTR),IBHAD(MSTR),ISTR
15376
15377 DIMENSION PJ(4)
15378
15379 IF(IREJ.EQ.-1) THEN
15380 ICTOT = 0
15381 ICCOR = 0
15382 RETURN
15383 ELSE IF(IREJ.EQ.-2) THEN
15384 WRITE(LO,'(/1X,A,2I8)')
15385 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15386 RETURN
15387 ENDIF
15388C
15389 IREJ = 0
15390C
15391 NITER = 100
15392 ITER = 0
15393 ICTOT = ICTOT+ISTR
15394 IF(ISWMDL(25).LE.0) RETURN
15395C debug string entries
15396 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15397C
15398 50 CONTINUE
15399 ITER = ITER+1
15400 IF(ITER.GE.NITER) THEN
15401 IREJ = 1
15402 IF(IDEB(83).GE.2) THEN
15403 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15404 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15405 ENDIF
15406 RETURN
15407 ENDIF
15408C
15409C check mass limits
15410 ISTRO = ISTR
15411 DO 100 I=1,ISTRO
15412 IF(NCODE(I).LT.0) GOTO 99
15413 J1 = NPOS(1,I)
15414 NRPOM = IPHIST(2,J1)
15415 IF(NRPOM.GE.100) GOTO 99
15416 CMASS0 = PHEP(5,J1)
15417C get masses
15418 IF(NCODE(I).EQ.3) THEN
15419 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15420 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15421 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15422 & AM1,AM2,AM3,AM4,IP1,IP2)
15423 ELSE IF(NCODE(I).EQ.5) THEN
15424 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15425 & AM1,AM2)
15426 AM3 = 0.D0
15427 AM4 = 0.D0
15428 IP1 = 0
15429 IP2 = 0
15430 ELSE IF(NCODE(I).EQ.7) THEN
15431 GOTO 99
15432 ELSE IF(NCODE(I).LT.0) THEN
15433 GOTO 99
15434 ELSE
15435 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15436 & J1,NCODE(I)
15437 CALL PHO_ABORT
15438 ENDIF
15439 IF(IDEB(83).GE.5)
15440 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15441 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15442 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15443C select masses to correct
15444 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15445 DO 200 K=1,ISTRO
15446 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15447 J2 = NPOS(1,K)
15448C join quarks to gluon
15449 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15450C flavour check
15451 IFL1 = 0
15452 IFL2 = 0
15453 PROB1 = 0.D0
15454 PROB2 = 0.D0
15455 KK1 = NPOS(2,I)
15456 KK2 = NPOS(2,K)
15457 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15458 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15459 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15460 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15461 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15462 IFL1 = ABS(IDHEP(KK1))
15463 IF(IFL1.GT.2) THEN
15464 PROB1 = 0.1D0/MAX(CMASS,EPS)
15465 ELSE
15466 PROB1 = 0.9D0/MAX(CMASS,EPS)
15467 ENDIF
15468 ENDIF
15469 KK1 = ABS(NPOS(3,I))
15470 KK2 = ABS(NPOS(3,K))
15471 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15472 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15473 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15474 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15475 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15476 IFL2 = ABS(IDHEP(KK1))
15477 IF(IFL2.GT.2) THEN
15478 PROB2 = 0.1D0/MAX(CMASS,EPS)
15479 ELSE
15480 PROB2 = 0.9D0/MAX(CMASS,EPS)
15481 ENDIF
15482 ENDIF
15483 IF(IFL1+IFL2.EQ.0) GOTO 99
15484C fusion possible
15485 ICCOR = ICCOR+1
15486 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15487 JJ = 2
15488 JE = 3
15489 ELSE
15490 JJ = 3
15491 JE = 2
15492 ENDIF
15493 KK1 = ABS(NPOS(JJ,I))
15494 KK2 = ABS(NPOS(JJ,K))
15495 I1 = ABS(NPOS(JE,I))
15496 I2 = KK1
15497 IS = SIGN(1,I2-I1)
15498 I2 = I2 - IS
15499 K1 = KK2
15500 K2 = ABS(NPOS(JE,K))
15501 KS = SIGN(1,K2-K1)
15502 K1 = K1 + KS
15503 IP1 = NHEP+1
15504C copy mother partons of string I
15505 DO 300 II=I1,I2,IS
15506 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15507 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15508 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15509 300 CONTINUE
15510C register gluon
15511 DO 350 II=1,4
15512 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15513 350 CONTINUE
15514 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15515 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15516C copy mother partons of string K
15517 DO 400 II=K1,K2,KS
15518 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15519 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15520 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15521 400 CONTINUE
15522C create new string entry
15523 DO 450 II=1,4
15524 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15525 450 CONTINUE
15526 IP2 = IPOS
15527 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15528 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15529 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15530C delete string K in /POSTRG/
15531 NCODE(K) = -999
15532C update string I in /POSTRG/
15533 NPOS(1,I) = IPOS
15534 NPOS(2,I) = IP1
15535 NPOS(3,I) = -IP2
15536C calculate new CPC string codes
15537 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15538 & IPAR2(I),IPAR3(I),IPAR4(I))
15539 GOTO 99
15540 ENDIF
15541 ENDIF
15542 200 CONTINUE
15543 ENDIF
15544 99 CONTINUE
15545 100 CONTINUE
15546 IF(IDEB(83).GE.20) THEN
15547 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15548 IF(IDEB(83).GE.22) THEN
15549 CALL PHO_PRSTRG
15550 CALL PHO_PREVNT(0)
15551 ENDIF
15552 ENDIF
15553
15554 END
15555
15556*$ CREATE PHO_MASCOR.FOR
15557*COPY PHO_MASCOR
15558CDECK ID>, PHO_MASCOR
15559 SUBROUTINE PHO_MASCOR(IREJ)
15560C********************************************************************
15561C
15562C check and adjust parton momenta for fragmentation
15563C
15564C input: /POEVT1/
15565C /POSTRG/
15566C IREJ -1 initialization
15567C -2 output of statistics
15568C
15569C output: /POEVT1/
15570C /POSTRG/
15571C IREJ 0 successful
15572C 1 failure
15573C
15574C in case of very small string mass:
15575C - direct manipulation of /POEVT1/ and /POEVT2/
15576C - string will be deleted from /POSTRG/ (label -99)
15577C
15578C********************************************************************
15579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15580 SAVE
15581
15582 PARAMETER ( EPS = 1.D-10,
15583 & EMIN = 0.3D0,
15584 & DEPS = 1.D-15)
15585
15586C input/output channels
15587 INTEGER LI,LO
15588 COMMON /POINOU/ LI,LO
15589C event debugging information
15590 INTEGER NMAXD
15591 PARAMETER (NMAXD=100)
15592 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15593 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15594 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15595 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15596C internal rejection counters
15597 INTEGER NMXJ
15598 PARAMETER (NMXJ=60)
15599 CHARACTER*10 REJTIT
15600 INTEGER IFAIL
15601 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15602C model switches and parameters
15603 CHARACTER*8 MDLNA
15604 INTEGER ISWMDL,IPAMDL
15605 DOUBLE PRECISION PARMDL
15606 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15607C standard particle data interface
15608 INTEGER NMXHEP
15609 PARAMETER (NMXHEP=4000)
15610 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15611 DOUBLE PRECISION PHEP,VHEP
15612 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15613 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15614 & VHEP(4,NMXHEP)
15615C extension to standard particle data interface (PHOJET specific)
15616 INTEGER IMPART,IPHIST,ICOLOR
15617 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15618C color string configurations including collapsed strings and hadrons
15619 INTEGER MSTR
15620 PARAMETER (MSTR=500)
15621 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15622 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15623 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15624 & NNCH(MSTR),IBHAD(MSTR),ISTR
15625
15626 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15627
15628 IF(IREJ.EQ.-1) THEN
15629 ICTOT = 0
15630 ICCOR = 0
15631 RETURN
15632 ELSE IF(IREJ.EQ.-2) THEN
15633 WRITE(LO,'(/1X,A,2I8/)')
15634 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15635 RETURN
15636 ENDIF
15637
15638 IREJ = 0
15639 NITER = 100
15640 ITER = 0
15641 ICTOT = ICTOT+ISTR
15642 IF(ISWMDL(7).EQ.-1) RETURN
15643C debug /POSTRG/
15644 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15645
15646 ITOUCH = 0
15647 50 CONTINUE
15648 ITER = ITER+1
15649 IF(ITER.GE.NITER) THEN
15650 IREJ = 1
15651 IF(IDEB(42).GE.2) THEN
15652 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15653 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15654 ENDIF
15655 RETURN
15656 ENDIF
15657
15658C check mass limits
15659 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15660 IM1 = 1
15661 IM2 = ISTR
15662 IST = 1
15663 ELSE
15664 IM1 = ISTR
15665 IM2 = 1
15666 IST = -1
15667 ENDIF
15668 DO 100 I=IM1,IM2,IST
15669 J1 = NPOS(1,I)
15670 CMASS0 = PHEP(5,J1)
15671C get masses
15672 IF(NCODE(I).EQ.3) THEN
15673 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15674 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15675 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15676 & AM1,AM2,AM3,AM4,IP1,IP2)
15677 ELSE IF(NCODE(I).EQ.5) THEN
15678 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15679 & AM1,AM2)
15680 AM3 = 0.D0
15681 AM4 = 0.D0
15682 IP1 = 0
15683 IP2 = 0
15684 ELSE IF(NCODE(I).EQ.7) THEN
15685 AM1 = 0.15D0
15686 AM2 = 0.3D0
15687 AM3 = 0.765D0
15688 AM4 = 1.5D0
15689*??????????????????????????????????
15690 IP1 = 23
15691 IP2 = 33
15692*??????????????????????????????????
15693 ELSE IF(NCODE(I).LT.0) THEN
15694 GOTO 90
15695 ELSE
15696 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15697 & J1,NCODE(I)
15698 CALL PHO_ABORT
15699 ENDIF
15700 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15701 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15702 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15703C select masses to correct
15704 IBHAD(I) = 0
15705 NNCH(I) = 0
15706C correction needed?
15707C no resonances for diquark-antidiquark and gluon-gluon strings
15708 IF(NCODE(I).EQ.5) THEN
15709 IF(CMASS0.LT.1.3D0*AM1) THEN
15710 IF(ISWMDL(7).LE.2) THEN
15711 IBHAD(I) = 90
15712 NNCH(I) = -1
15713 CHMASS = AM1*1.3D0
15714 ELSE
15715 IREJ = 1
15716 RETURN
15717 ENDIF
15718 ENDIF
15719 ELSE
15720 INEED = 0
15721C resonances possible
15722 IF(ISWMDL(7).EQ.0) THEN
15723 IF(CMASS0.LT.AM1*0.99D0) THEN
15724 IBHAD(I) = IP1
15725 NNCH(I) = -1
15726 CHMASS = AM1
15727 INEED = 1
15728 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15729 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15730 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15731 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15732 IBHAD(I) = IP1
15733 NNCH(I) = -1
15734 CHMASS = AM1
15735 ELSE
15736 IBHAD(I) = IP2
15737 NNCH(I) = 1
15738 CHMASS = AM3
15739 ENDIF
15740 ENDIF
15741 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15742 IF(CMASS0.LT.AM1*0.99) THEN
15743 IBHAD(I) = IP1
15744 NNCH(I) = -1
15745 CHMASS = AM1
15746 INEED = 1
15747 ENDIF
15748 ELSE IF(ISWMDL(7).EQ.3) THEN
15749 IF(CMASS0.LT.AM1) THEN
15750 IREJ = 1
15751 RETURN
15752 ENDIF
15753 ELSE
15754 WRITE(LO,'(/1X,A,I5)')
15755 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15756 CALL PHO_ABORT
15757 ENDIF
15758 ENDIF
15759C
15760C correction necessary?
15761 IF(IBHAD(I).NE.0) THEN
15762C find largest invar. mass
15763 IPOS = 0
15764 CMASS1 = -1.D0
15765 DO 200 J2=NHEP,3,-1
15766 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15767 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15768 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15769 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15770 CALL PHO_PREVNT(0)
15771 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15772 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15773 & -(PHEP(1,J1)+PHEP(1,J2))**2
15774 & -(PHEP(2,J1)+PHEP(2,J2))**2
15775 & -(PHEP(3,J1)+PHEP(3,J2))**2
15776 IF(CMASS2.GT.CMASS1) THEN
15777 IPOS=J2
15778 CMASS1=CMASS2
15779 ENDIF
15780 ENDIF
15781 ENDIF
15782 200 CONTINUE
15783 J2 = IPOS
15784 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15785 IF(INEED.EQ.1) THEN
15786 IREJ = 1
15787 RETURN
15788 ELSE
15789 IBHAD(I) = 0
15790 NNCH(I) = 0
15791 GOTO 90
15792 ENDIF
15793 ENDIF
15794 ISTA = ISTHEP(J1)
15795 ISTB = ISTHEP(J2)
15796 CMASS1 = SQRT(CMASS1)
15797 CMASS2 = PHEP(5,J2)
15798 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15799 IREJ = 1
15800 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15801 & CHMASS,CMASS2,PC1,PC2,IREJ)
15802 IF(IREJ.NE.0) THEN
15803 IFAIL(24) = IFAIL(24)+1
15804 IF(IDEB(42).GE.2) THEN
15805 WRITE(LO,'(1X,A,2I4)')
15806 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15807 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15808 ENDIF
15809 IREJ = 1
15810 RETURN
15811 ENDIF
15812C momentum transfer
15813 DO 210 II=1,4
15814 PTR(II) = PHEP(II,J2)-PC2(II)
15815 210 CONTINUE
15816 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15817 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15818C copy parents of strings
15819C register partons belonging to first string
15820 IF(IDHEP(J1).EQ.90) THEN
15821 K1 = JMOHEP(1,J1)
15822 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15823 ESUM = 0.D0
15824 DO 500 II=K1,K2
15825 ESUM = ESUM+PHEP(4,II)
15826 500 CONTINUE
15827 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15828 DO 600 II=K1,K2
15829 FAC = PHEP(4,II)/ESUM
15830 DO 650 K=1,4
15831 P1(K) = PHEP(K,II)+FAC*PTR(K)
15832 650 CONTINUE
15833 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15834 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15835 & ICOLOR(2,II),IPOS,1)
15836 600 CONTINUE
15837 K1A = IPOS+K1-K2
15838 IF(JMOHEP(2,J1).GT.0) THEN
15839 II = JMOHEP(2,J1)
15840 FAC = PHEP(4,II)/ESUM
15841 DO 675 K=1,4
15842 P1(K) = PHEP(K,II)+FAC*PTR(K)
15843 675 CONTINUE
15844 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15845 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15846 & ICOLOR(2,II),IPOS,1)
15847 ENDIF
15848 K2A = -IPOS
15849 ELSE
15850 K1A = J1
15851 K2A = J2
15852 ENDIF
15853C register partons belonging to second string
15854 IF(IDHEP(J2).EQ.90) THEN
15855 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15856 K1 = JMOHEP(1,J2)
15857 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15858 ESUM = 0.D0
15859 DO 300 II=K1,K2
15860 ESUM = ESUM+PHEP(4,II)
15861 300 CONTINUE
15862 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15863 DO 400 II=K1,K2
15864**sr 28.12.2006 fix adopted from FLUKA
15865C FAC = PHEP(4,II)/ESUM
15866 IF (ABS(ESUM).GT.0.D0) THEN
15867 FAC = PHEP(4,II)/ESUM
15868 ELSE
15869 FAC = 1.0D0
15870 ENDIF
15871**
15872 IF(IREJL.EQ.0) THEN
15873 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15874 P1(4) = P1(4)+FAC*DELE
15875 ELSE
15876 DO 450 K=1,4
15877 P1(K) = PHEP(K,II)-FAC*PTR(K)
15878 450 CONTINUE
15879 ENDIF
15880 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15881 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15882 & ICOLOR(2,II),IPOS,1)
15883 400 CONTINUE
15884 K1B = IPOS+K1-K2
15885 IF(JMOHEP(2,J2).GT.0) THEN
15886 II = JMOHEP(2,J2)
15887 FAC = PHEP(4,II)/ESUM
15888 IF(IREJL.EQ.0) THEN
15889 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15890 P1(4) = P1(4)+FAC*DELE
15891 ELSE
15892 DO 475 K=1,4
15893 P1(K) = PHEP(K,II)-FAC*PTR(K)
15894 475 CONTINUE
15895 ENDIF
15896 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15897 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15898 & ICOLOR(2,II),IPOS,1)
15899 ENDIF
15900 K2B = -IPOS
15901 ELSE
15902 K1B = J1
15903 K2B = J2
15904 ENDIF
15905C register first string/collapsed to hadron
15906 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15907 IF(NCODE(I).NE.5) THEN
15908 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15909 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15910C label string as collapsed to hadron/resonance
15911 NCODE(I) = -99
15912 IDHEP(J1) = 92
15913 ELSE
15914 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15915 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15916 IDHEP(J1) = 91
15917 ENDIF
15918 NPOS(1,I) = IPOS
15919 NPOS(2,I) = K1A
15920 NPOS(3,I) = K2A
15921 ELSE
15922 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15923 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15924 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15925 IF(IDHEP(J1).EQ.90) THEN
15926 NPOS(1,IPHIST(1,J1)) = IPOS
15927 NPOS(2,IPHIST(1,J1)) = K1A
15928 NPOS(3,IPHIST(1,J1)) = K2A
15929C label string as collapsed to resonance-string
15930 IDHEP(J1) = 91
15931 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15932 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15933 ENDIF
15934 ENDIF
15935C register second string/hadron/parton
15936 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15937 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15938 & ICOLOR(2,J2),IPOS,1)
15939 IF(IDHEP(J2).EQ.90) THEN
15940 NPOS(1,IPHIST(1,J2))=IPOS
15941 NPOS(2,IPHIST(1,J2))=K1B
15942 NPOS(3,IPHIST(1,J2))=K2B
15943C label string touched by momentum transfer
15944 IDHEP(J2) = 91
15945 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15946 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15947 ENDIF
15948 ICCOR = ICCOR+1
15949 ITOUCH = ITOUCH+1
15950C consistency checks
15951 IF(IDEB(42).GE.5) THEN
15952 CALL PHO_CHECK(-1,IDEV)
15953 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15954 ENDIF
15955C jump to next iteration
15956 GOTO 50
15957 ENDIF
15958 90 CONTINUE
15959 100 CONTINUE
15960C debug output
15961 IF(IDEB(42).GE.15) THEN
15962 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15963 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15964 CALL PHO_PREVNT(1)
15965 ENDIF
15966 ENDIF
15967 END
15968
15969*$ CREATE PHO_PARCOR.FOR
15970*COPY PHO_PARCOR
15971CDECK ID>, PHO_PARCOR
15972 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15973C********************************************************************
15974C
15975C conversion of string partons (using JETSET masses)
15976C
15977C input: MODE >0 position index of corresponding string
15978C -1 initialization
15979C -2 output of statistics
15980C
15981C output: /POSTRG/
15982C IREJ 1 combination of strings impossible
15983C 0 successful combination
15984C
15985C********************************************************************
15986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15987 SAVE
15988
15989 PARAMETER ( DELM = 0.005D0,
15990 & DEPS = 1.D-15,
15991 & EPS = 1.D-5)
15992
15993C input/output channels
15994 INTEGER LI,LO
15995 COMMON /POINOU/ LI,LO
15996C event debugging information
15997 INTEGER NMAXD
15998 PARAMETER (NMAXD=100)
15999 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16000 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16001 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16002 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16003C internal rejection counters
16004 INTEGER NMXJ
16005 PARAMETER (NMXJ=60)
16006 CHARACTER*10 REJTIT
16007 INTEGER IFAIL
16008 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16009C model switches and parameters
16010 CHARACTER*8 MDLNA
16011 INTEGER ISWMDL,IPAMDL
16012 DOUBLE PRECISION PARMDL
16013 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16014C standard particle data interface
16015 INTEGER NMXHEP
16016 PARAMETER (NMXHEP=4000)
16017 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16018 DOUBLE PRECISION PHEP,VHEP
16019 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16020 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16021 & VHEP(4,NMXHEP)
16022C extension to standard particle data interface (PHOJET specific)
16023 INTEGER IMPART,IPHIST,ICOLOR
16024 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16025C color string configurations including collapsed strings and hadrons
16026 INTEGER MSTR
16027 PARAMETER (MSTR=500)
16028 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16029 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16030 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16031 & NNCH(MSTR),IBHAD(MSTR),ISTR
16032
16033 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16034 & PL(4,100),XMP(100),XML(100)
16035
16036 DOUBLE PRECISION PYMASS
16037
16038 IREJ = 0
16039 IMODE = MODE
16040C
16041 IF(IMODE.GT.0) THEN
16042 ICH = 0
16043 I1 = JMOHEP(1,IMODE)
16044 I2 = ABS(JMOHEP(2,IMODE))
16045C copy to local field
16046 L = 0
16047 DO 100 I=I1,I2
16048 L = L+1
16049 DO 200 K=1,4
16050 PL(K,L) = PHEP(K,I)
16051 200 CONTINUE
16052 XMP(L) = PHEP(5,I)
16053 XML(L) = PYMASS(IDHEP(I))
16054 100 CONTINUE
16055 IPAR = L
16056 XMC = PHEP(5,IMODE)
16057 IF(IDEB(82).GE.20) THEN
16058 WRITE(LO,'(1X,A,I7,2I4)')
16059 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16060 & KEVENT,IMODE,L
16061 DO 150 I=1,L
16062 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16063 & XMP(I),XML(I)
16064 150 CONTINUE
16065 ENDIF
16066C
16067C two parton configurations
16068C -----------------------------------------
16069 IF(IPAR.EQ.2) THEN
16070 XM1 = XML(1)
16071 XM2 = XML(2)
16072 IF((XM1+XM2).GE.XMC) THEN
16073 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16074 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16075 & IMODE,XM1,XM2,XMC
16076 GOTO 990
16077 ENDIF
16078C conversion possible
16079 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16080 IF(IREJ.NE.0) THEN
16081 IFAIL(36) = IFAIL(36)+1
16082 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16083 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16084 & KEVENT,IMODE,XMC
16085 GOTO 990
16086 ENDIF
16087 ICH = 1
16088 DO 115 K=1,4
16089 PL(K,1) = PP1(K)
16090 PL(K,2) = PP2(K)
16091 XMP(1) = XM1
16092 XMP(2) = XM2
16093 115 CONTINUE
16094C
16095C multi parton configurations
16096C ---------------------------------
16097 ELSE
16098C
16099C random selection of string side to start with
16100 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16101 K1 = 1
16102 K2 = IPAR
16103 KS = 1
16104 ELSE
16105 K1 = IPAR
16106 K2 = 1
16107 KS = -1
16108 ENDIF
16109 ITER = 0
16110C
16111 300 CONTINUE
16112 IF(ITER.LT.4) THEN
16113 KK = K1
16114 K1 = K2
16115 K2 = KK
16116 KS = -KS
16117 ELSE
16118 GOTO 990
16119 ENDIF
16120 ITER = ITER+1
16121C select method
16122 IF(ITER.GT.2) GOTO 230
16123
16124C conversion according to color flow method
16125 IFAI = 0
16126 DO 210 II=K1,K2-KS,KS
16127 DO 215 IK=II+KS,K2,KS
16128 XM1 = XML(II)
16129 XM2 = XML(IK)
16130* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16131* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16132 IF((ABS(XM1-XMP(II)).GT.DELM)
16133 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16134 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16135 IF(IREJ.NE.0) THEN
16136 IFAIL(36) = IFAIL(36)+1
16137 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16138 & 'PHO_PARCOR: ',
16139 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16140 & KEVENT,IMODE,II,IK
16141 IREJ = 0
16142 ELSE
16143 ICH = ICH+1
16144 DO 220 KK=1,4
16145 PL(KK,II) = PP1(KK)
16146 PL(KK,IK) = PP2(KK)
16147 220 CONTINUE
16148 XMP(II) = XM1
16149 XMP(IK) = XM2
16150 GOTO 219
16151 ENDIF
16152 ELSE
16153 GOTO 219
16154 ENDIF
16155 215 CONTINUE
16156 IFAI = II
16157 219 CONTINUE
16158 210 CONTINUE
16159 IF(IFAI.NE.0) GOTO 300
16160 GOTO 950
16161C
16162 230 CONTINUE
16163C
16164C conversion according to remainder method
16165 DO 350 I=K1,K2,KS
16166 XM1 = XML(I)
16167 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16168 ICH = ICH+1
16169 IFAI = I
16170C conversion necessary
16171 DO 400 K=1,4
16172 PB1(K) = PL(K,I)
16173 PB2(K) = PHEP(K,IMODE)-PB1(K)
16174 400 CONTINUE
16175 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16176 IF(XM2.LT.0.D0) THEN
16177 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16178 & 'PHO_PARCOR: ',
16179 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16180 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16181 GOTO 300
16182 ENDIF
16183 XM2 = SQRT(XM2)
16184 IF((XM1+XM2).GE.XMC) THEN
16185 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16186 & 'PHO_PARCOR: ',
16187 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16188 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16189 GOTO 300
16190 ENDIF
16191C conversion possible
16192 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16193 IF(IREJ.NE.0) THEN
16194 IFAIL(36) = IFAIL(36)+1
16195 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16196 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16197 & ITER,IMODE,I
16198 GOTO 300
16199 ENDIF
16200C calculate Lorentz transformation
16201 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16202 IF(IREJ.NE.0) THEN
16203 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16204 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16205 & ITER,IMODE,I
16206 GOTO 300
16207 ENDIF
16208 IFAI = 0
16209C transform remaining partons
16210 DO 450 L=K1,K2,KS
16211 IF(L.NE.I) THEN
16212 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16213 DO 500 K=1,4
16214 PL(K,L) = PP2(K)
16215 500 CONTINUE
16216 ELSE
16217 DO 550 K=1,4
16218 PL(K,L) = PP1(K)
16219 550 CONTINUE
16220 ENDIF
16221 450 CONTINUE
16222 XMP(I) = XM1
16223 ENDIF
16224 350 CONTINUE
16225 ENDIF
16226
16227C register transformed partons
16228 950 CONTINUE
16229 IREJ = 0
16230 IF(ICH.NE.0) THEN
16231 IP1 = NHEP+1
16232 L = 0
16233 DO 700 I=I1,I2
16234 L= L+1
16235 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16236 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16237 & ICOLOR(2,I),IPOS,1)
16238 700 CONTINUE
16239 IP2 = IPOS
16240C register string
16241 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16242 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16243 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16244C update /POSTRG/
16245 I = IPHIST(1,IMODE)
16246 NPOS(1,I) = IPOS
16247 NPOS(2,I) = IP1
16248 NPOS(3,I) = -IP2
16249 ENDIF
16250C debug output
16251 IF(IDEB(82).GE.20) THEN
16252 WRITE(LO,'(1X,A,I7,2I4)')
16253 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16254 & KEVENT,IMODE,L
16255 DO 850 I=1,L
16256 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16257 & XMP(I),XML(I)
16258 850 CONTINUE
16259 WRITE(LO,'(1X,A,2I5)')
16260 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16261 ENDIF
16262 RETURN
16263C rejection
16264 990 CONTINUE
16265 IREJ = 1
16266 IF(IDEB(82).GE.3) THEN
16267 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16268 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16269 & IFAI,IPAR,IMODE,XMC
16270 IF(IDEB(82).GE.5) THEN
16271 WRITE(LO,'(1X,A,I7,2I4)')
16272 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16273 & KEVENT,IMODE,IPAR
16274 DO 155 I=1,IPAR
16275 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16276 & XMP(I),XML(I)
16277 155 CONTINUE
16278 ENDIF
16279 ENDIF
16280 RETURN
16281
16282 ELSE IF(IMODE.EQ.-1) THEN
16283C initialization
16284 RETURN
16285
16286 ELSE IF(IMODE.EQ.-2) THEN
16287C final output
16288 RETURN
16289 ENDIF
16290 END
16291
16292*$ CREATE PHO_STRING.FOR
16293*COPY PHO_STRING
16294CDECK ID>, PHO_STRING
16295 SUBROUTINE PHO_STRING(IMODE,IREJ)
16296C********************************************************************
16297C
16298C calculation of string combinatorics, Lorentz boosts and
16299C particle codes
16300C
16301C - splitting of gluons
16302C - strings will be built up from pairs of partons
16303C according to their color labels
16304C with IDHEP(..) = -1
16305C - there can be other particles between to string partons
16306C (these will be unchanged by string construction)
16307C - string mass fine correction
16308C
16309C input: IMODE 1 complete string processing
16310C -1 initialization
16311C -2 output of statistics
16312C
16313C output: /POSTRG/
16314C IREJ 1 combination of strings impossible
16315C 0 successful combination
16316C 50 rejection due to user cutoffs
16317C
16318C********************************************************************
16319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16320 SAVE
16321
16322 PARAMETER ( DEPS = 1.D-15,
16323 & EPS = 1.D-5 )
16324
16325C input/output channels
16326 INTEGER LI,LO
16327 COMMON /POINOU/ LI,LO
16328C event debugging information
16329 INTEGER NMAXD
16330 PARAMETER (NMAXD=100)
16331 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16332 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16333 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16334 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16335C general process information
16336 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16337 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16338C internal rejection counters
16339 INTEGER NMXJ
16340 PARAMETER (NMXJ=60)
16341 CHARACTER*10 REJTIT
16342 INTEGER IFAIL
16343 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16344C model switches and parameters
16345 CHARACTER*8 MDLNA
16346 INTEGER ISWMDL,IPAMDL
16347 DOUBLE PRECISION PARMDL
16348 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16349C hard cross sections and MC selection weights
16350 INTEGER Max_pro_2
16351 PARAMETER ( Max_pro_2 = 16 )
16352 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16353 & MH_acc_1,MH_acc_2
16354 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16355 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16356 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16357 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16358 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16359 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16360C standard particle data interface
16361 INTEGER NMXHEP
16362 PARAMETER (NMXHEP=4000)
16363 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16364 DOUBLE PRECISION PHEP,VHEP
16365 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16366 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16367 & VHEP(4,NMXHEP)
16368C extension to standard particle data interface (PHOJET specific)
16369 INTEGER IMPART,IPHIST,ICOLOR
16370 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16371C color string configurations including collapsed strings and hadrons
16372 INTEGER MSTR
16373 PARAMETER (MSTR=500)
16374 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16375 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16376 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16377 & NNCH(MSTR),IBHAD(MSTR),ISTR
16378C table of particle indices for recursive PHOJET calls
16379 INTEGER MAXIPX
16380 PARAMETER ( MAXIPX = 100 )
16381 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16382 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16383 & IPOIX1,IPOIX2,IPOIX3
16384C some constants
16385 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16386 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16387 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16388
16389 IREJ = 0
16390 IF(IMODE.EQ.-1) THEN
16391 CALL PHO_POMCOR(-1)
16392 CALL PHO_MASCOR(-1)
16393 CALL PHO_PARCOR(-1,IREJ)
16394 RETURN
16395 ELSE IF(IMODE.EQ.-2) THEN
16396 CALL PHO_POMCOR(-2)
16397 CALL PHO_MASCOR(-2)
16398 CALL PHO_PARCOR(-2,IREJ)
16399 RETURN
16400 ENDIF
16401
16402C generate enhanced graphs
16403 IF(IPOIX2.GT.0) THEN
16404 200 CONTINUE
16405 I1 = MAX(1,IPOIX1)
16406 I2 = IPOIX2
16407 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16408 KSPOMS = KSPOM-1
16409 KSREGS = KSREG
16410 KHPOMS = KHPOM
16411 KHDIRS = KHDIR
16412 IDDFS1 = IDIFR1
16413 IDDFS2 = IDIFR2
16414 IDDPOS = IDDPOM
16415 DO 110 I=I1,I2
16416 IPOIX3 = I
16417 KSPOM = 0
16418 KSREG = 0
16419 KHPOM = 0
16420 KHDIR = 0
16421 IF(IPORES(I).EQ.8) THEN
16422 KSPOM = 2
16423 LSPOM = 2
16424 LHPOM = 0
16425 LSREG = 0
16426 LHDIR = 0
16427 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16428 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16429 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16430 IF(IREJ.NE.0) THEN
16431 IF(IDEB(4).GE.2) THEN
16432 WRITE(LO,'(/1X,A,I5)')
16433 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16434 CALL PHO_PREVNT(-1)
16435 ENDIF
16436 RETURN
16437 ENDIF
16438 KSPOM = KSPOMS+LSPOM
16439 KSREG = KSREGS+LSREG
16440 KHPOM = KHPOMS+LHPOM
16441 KHDIR = KHDIRS+LHDIR
16442 ELSE IF(IPORES(I).EQ.4) THEN
16443 ITEMP = ISWMDL(17)
16444 ISWMDL(17) = 0
16445 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16446 ISWMDL(17) = ITEMP
16447 IF(IREJ.NE.0) THEN
16448 IF(IDEB(4).GE.2) THEN
16449 WRITE(LO,'(/1X,A,I5)')
16450 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16451 CALL PHO_PREVNT(-1)
16452 ENDIF
16453 RETURN
16454 ENDIF
16455 KSDPO = KSDPO+1
16456 KSPOM = KSPOMS+KSPOM
16457 KSREG = KSREGS+KSREG
16458 KHPOM = KHPOMS+KHPOM
16459 KHDIR = KHDIRS+KHDIR
16460 ELSE
16461 IDIF1 = 1
16462 IDIF2 = 1
16463 IF(IPORES(I).EQ.5) THEN
16464 IDIF2 = 0
16465 KSTRG = KSTRG+1
16466 ELSE IF(IPORES(I).EQ.6) THEN
16467 IDIF1 = 0
16468 KSTRG = KSTRG+1
16469 ELSE
16470 KSLOO = KSLOO+1
16471 ENDIF
16472 ITEMP = ISWMDL(16)
16473 ISWMDL(16) = 0
16474 SPROB = 1.D0
16475 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16476 & 0,MSOFT,MHARD,IREJ)
16477 ISWMDL(16) = ITEMP
16478 IF(IREJ.NE.0) THEN
16479 IF(IDEB(4).GE.2) THEN
16480 WRITE(LO,'(/1X,A,I5)')
16481 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16482 CALL PHO_PREVNT(-1)
16483 ENDIF
16484 RETURN
16485 ENDIF
16486 KSPOM = KSPOMS+KSPOM
16487 KSREG = KSREGS+KSREG
16488 KHPOM = KHPOMS+KHPOM
16489 KHDIR = KHDIRS+KHDIR
16490 ENDIF
16491 IDIFR1 = IDDFS1
16492 IDIFR2 = IDDFS2
16493 IDDPOM = IDDPOS
16494 110 CONTINUE
16495 IF(IPOIX2.GT.I2) THEN
16496 IPOIX1 = I2+1
16497 GOTO 200
16498 ENDIF
16499 ENDIF
16500
16501C optional: split gluons to q-qbar pairs
16502 IF(ISWMDL(9).GT.0) THEN
16503 NHEPO = NHEP
16504 DO 30 I=3,NHEPO
16505 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16506 ICG1=ICOLOR(1,I)
16507 ICG2=ICOLOR(2,I)
16508 IQ1 = 0
16509 IQ2 = 0
16510 DO 40 K=3,NHEPO
16511 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16512 IQ1 = K
16513 IF(IQ1*IQ2.NE.0) GOTO 45
16514 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16515 IQ2 = K
16516 IF(IQ1*IQ2.NE.0) GOTO 45
16517 ENDIF
16518 40 CONTINUE
16519 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16520 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16521 CALL PHO_ABORT
16522 45 CONTINUE
16523 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16524 IF(IREJ.NE.0) THEN
16525 IF(IDEB(19).GE.5) THEN
16526 WRITE(LO,'(/,1X,A)')
16527 & 'PHO_STRING: no gluon splitting possible'
16528 CALL PHO_PREVNT(0)
16529 ENDIF
16530 RETURN
16531 ENDIF
16532 ENDIF
16533 30 CONTINUE
16534 ENDIF
16535
16536C construct strings and write entries sorted by strings
16537
16538 ISTR = ISTR+1
16539 NHEPO = NHEP
16540 DO 50 I=3,NHEPO
16541 IF(ISTR.GT.MSTR) THEN
16542 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16543 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16544 CALL PHO_PREVNT(0)
16545 IREJ = 1
16546 RETURN
16547 ENDIF
16548 IF(ISTHEP(I).EQ.1) THEN
16549C hadrons / resonances / clusters
16550 NPOS(1,ISTR) = I
16551 NPOS(2,ISTR) = 0
16552 NPOS(3,ISTR) = 0
16553 NPOS(4,ISTR) = abs(IPHIST(2,I))
16554 NCODE(ISTR) = -99
16555 IPHIST(1,I) = ISTR
16556 ISTR = ISTR+1
16557 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16558C quark /diquark terminated strings
16559 ICOL1 = -ICOLOR(1,I)
16560 P1 = PHEP(1,I)
16561 P2 = PHEP(2,I)
16562 P3 = PHEP(3,I)
16563 P4 = PHEP(4,I)
16564 ICH1 = IPHO_CHR3(I,2)
16565 IBA1 = IPHO_BAR3(I,2)
16566 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16567 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16568 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16569 JM1 = IPOS
16570
16571 NRPOM = 0
16572 65 CONTINUE
16573 DO 55 K=3,NHEPO
16574 IF(ISTHEP(K).EQ.-1)THEN
16575 IF(IDHEP(K).EQ.21) THEN
16576 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16577 ICOL1 = -ICOLOR(2,K)
16578 GOTO 60
16579 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16580 ICOL1 = -ICOLOR(1,K)
16581 GOTO 60
16582 ENDIF
16583 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16584 ICOL1 = 0
16585 GOTO 60
16586 ENDIF
16587 ENDIF
16588 55 CONTINUE
16589 WRITE(LO,'(/1X,A,I5)')
16590 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16591 CALL PHO_ABORT
16592 60 CONTINUE
16593 P1 = P1+PHEP(1,K)
16594 P2 = P2+PHEP(2,K)
16595 P3 = P3+PHEP(3,K)
16596 P4 = P4+PHEP(4,K)
16597 NRPOM = MAX(NRPOM,IPHIST(1,K))
16598 ICH1 = ICH1+IPHO_CHR3(K,2)
16599 IBA1 = IBA1+IPHO_BAR3(K,2)
16600 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16601 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16602 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16603C further parton involved?
16604 IF(ICOL1.NE.0) GOTO 65
16605 JM2 = IPOS
16606C register string
16607 IGEN = IPHIST(2,K)
16608 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16609 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16610C store additional string information
16611 NPOS(1,ISTR) = IPOS
16612 NPOS(2,ISTR) = JM1
16613 NPOS(3,ISTR) = -JM2
16614 NPOS(4,ISTR) = abs(IPHIST(2,K))
16615C calculate CPC string codes
16616 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16617 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16618 ISTR = ISTR+1
16619 ENDIF
16620 50 CONTINUE
16621
16622 DO 150 I=3,NHEPO
16623 IF(ISTR.GT.MSTR) THEN
16624 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16625 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16626 CALL PHO_PREVNT(0)
16627 IREJ = 1
16628 RETURN
16629 ENDIF
16630 IF(ISTHEP(I).EQ.-1) THEN
16631C gluon loop-strings
16632 ICOL1 = -ICOLOR(1,I)
16633 P1 = PHEP(1,I)
16634 P2 = PHEP(2,I)
16635 P3 = PHEP(3,I)
16636 P4 = PHEP(4,I)
16637 IBA1 = 0
16638 ICH1 = 0
16639 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16640 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16641 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16642 JM1 = IPOS
16643C
16644 NRPOM = 0
16645 165 CONTINUE
16646 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16647 DO 155 K=I,NHEPO
16648 IF(ISTHEP(K).EQ.-1)THEN
16649 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16650 ICOL1 = -ICOLOR(2,K)
16651 GOTO 160
16652 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16653 ICOL1 = -ICOLOR(1,K)
16654 GOTO 160
16655 ENDIF
16656 ENDIF
16657 155 CONTINUE
16658 WRITE(LO,'(/1X,A,I5)')
16659 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16660 CALL PHO_ABORT
16661 160 CONTINUE
16662 P1 = P1+PHEP(1,K)
16663 P2 = P2+PHEP(2,K)
16664 P3 = P3+PHEP(3,K)
16665 P4 = P4+PHEP(4,K)
16666 NRPOM = MAX(NRPOM,IPHIST(1,K))
16667 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16668 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16669 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16670C further parton involved?
16671 IF(ICOL1.NE.0) GOTO 165
16672 170 CONTINUE
16673 JM2 = IPOS
16674C register string
16675 IGEN = IPHIST(2,K)
16676 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16677 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16678C store additional string information
16679 NPOS(1,ISTR) = IPOS
16680 NPOS(2,ISTR) = JM1
16681 NPOS(3,ISTR) = -JM2
16682 NPOS(4,ISTR) = abs(IPHIST(2,K))
16683C calculate CPC string codes
16684 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16685 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16686 ISTR = ISTR+1
16687 ENDIF
16688 150 CONTINUE
16689
16690 ISTR = ISTR-1
16691
16692 IF(IDEB(19).GE.17) THEN
16693 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16694 CALL PHO_PREVNT(0)
16695 ENDIF
16696
16697C pomeron corrections
16698 CALL PHO_POMCOR(IREJ)
16699 IF(IREJ.NE.0) THEN
16700 IFAIL(38) = IFAIL(38)+1
16701 IF(IDEB(19).GE.3) THEN
16702 WRITE(LO,'(1X,A,I6)')
16703 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16704 CALL PHO_PREVNT(-1)
16705 ENDIF
16706 RETURN
16707 ENDIF
16708
16709C string mass corrections
16710 CALL PHO_MASCOR(IREJ)
16711 IF(IREJ.NE.0) THEN
16712 IFAIL(34) = IFAIL(34)+1
16713 IF(IDEB(19).GE.3) THEN
16714 WRITE(LO,'(1X,A,I6)')
16715 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16716 CALL PHO_PREVNT(-1)
16717 ENDIF
16718 RETURN
16719 ENDIF
16720
16721C parton mass corrections
16722 DO 100 I=1,ISTR
16723 IF(NCODE(I).GE.0) THEN
16724 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16725 IF(IREJ.NE.0) THEN
16726 IFAIL(35) = IFAIL(35)+1
16727 IF(IDEB(19).GE.3) THEN
16728 WRITE(LO,'(1X,A,I6)')
16729 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16730 CALL PHO_PREVNT(-1)
16731 ENDIF
16732 RETURN
16733 ENDIF
16734 ENDIF
16735 100 CONTINUE
16736
16737C statistics of hard processes
16738 DO 550 I=3,NHEP
16739 IF(ISTHEP(I).EQ.25) THEN
16740 K = IMPART(I)
16741 II = IDHEP(I)
16742 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16743 ENDIF
16744 550 CONTINUE
16745
16746C debug: write out strings
16747 IF(IDEB(19).GE.5) THEN
16748 IF(IDEB(19).GE.10)
16749 & CALL PHO_CHECK(1,IDEV)
16750 IF(IDEB(19).GE.15) THEN
16751 CALL PHO_PREVNT(0)
16752 ELSE
16753 CALL PHO_PRSTRG
16754 ENDIF
16755 ENDIF
16756
16757 END
16758
16759*$ CREATE PHO_STRFRA.FOR
16760*COPY PHO_STRFRA
16761CDECK ID>, PHO_STRFRA
16762 SUBROUTINE PHO_STRFRA(IREJ)
16763C********************************************************************
16764C
16765C do all fragmentation of strings
16766C
16767C output: IREJ 0 successful
16768C 1 rejection
16769C 50 rejection due to user cutoffs
16770C
16771C********************************************************************
16772 IMPLICIT NONE
16773 SAVE
16774
16775C input/output channels
16776 INTEGER LI,LO
16777 COMMON /POINOU/ LI,LO
16778C some constants
16779 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16780 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16781 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16782C event debugging information
16783 INTEGER NMAXD
16784 PARAMETER (NMAXD=100)
16785 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16786 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16787 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16788 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16789C general process information
16790 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16791 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16792C model switches and parameters
16793 CHARACTER*8 MDLNA
16794 INTEGER ISWMDL,IPAMDL
16795 DOUBLE PRECISION PARMDL
16796 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16797C global event kinematics and particle IDs
16798 INTEGER IFPAP,IFPAB
16799 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16800 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16801C standard particle data interface
16802 INTEGER NMXHEP
16803 PARAMETER (NMXHEP=4000)
16804 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16805 DOUBLE PRECISION PHEP,VHEP
16806 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16807 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16808 & VHEP(4,NMXHEP)
16809C extension to standard particle data interface (PHOJET specific)
16810 INTEGER IMPART,IPHIST,ICOLOR
16811 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16812C color string configurations including collapsed strings and hadrons
16813 INTEGER MSTR
16814 PARAMETER (MSTR=500)
16815 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16816 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16817 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16818 & NNCH(MSTR),IBHAD(MSTR),ISTR
16819
16820 INTEGER IREJ
16821
16822 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16823 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16824 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16825
16826 integer indx(500),indx_max
16827
16828 DOUBLE PRECISION DT_RNDM
16829 INTEGER ipho_pdg2id
16830 EXTERNAL DT_RNDM,ipho_pdg2id
16831
16832 DOUBLE PRECISION PYP,RQLUN
16833 INTEGER PYK
16834
16835 INTEGER MSTU,MSTJ
16836 DOUBLE PRECISION PARU,PARJ
16837 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16838 INTEGER N,NPAD,K
16839 DOUBLE PRECISION P,V
16840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16841
16842 DIMENSION IJOIN(100)
16843
16844 IREJ = 0
16845 IF(ABS(ISWMDL(6)).GT.3) THEN
16846 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16847 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16848 CALL PHO_ABORT
16849 ENDIF
16850
16851C popcorn suppression
16852 IF(PARMDL(134).GT.0.D0) THEN
16853 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16854 MSTJ(12) = 2
16855 ELSE
16856 MSTJ(12) = 1
16857 ENDIF
16858 ENDIF
16859
16860C copy partons to fragmentation code JETSET
16861 IP = 0
16862 IP_old = 1
16863
16864 DO 300 J=1,ISTR
16865
16866C select partons with common production process
16867 IGEN = NPOS(4,J)
16868 if(IGEN.lt.0) goto 299
16869
16870 indx_max = 0
16871 DO 400 I=J,ISTR
16872 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16873
16874C write final particles/resonances to JETSET
16875 IF(NCODE(I).EQ.-99) THEN
16876 II = NPOS(1,I)
16877 IP = IP+1
16878 P(IP,1) = PHEP(1,II)
16879 P(IP,2) = PHEP(2,II)
16880 P(IP,3) = PHEP(3,II)
16881 P(IP,4) = PHEP(4,II)
16882 P(IP,5) = PHEP(5,II)
16883 K(IP,1) = 1
16884 K(IP,2) = IDHEP(II)
16885 K(IP,3) = 0
16886 K(IP,4) = 0
16887 K(IP,5) = 0
16888 IPHIST(2,II) = IP
16889 if(indx_max.eq.500) then
16890 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16891 & 'no space left in index vector (indx,Kevent)',
16892 & indx_max,KEVENT
16893 IREJ = 1
16894 return
16895 endif
16896 indx_max = indx_max+1
16897 indx(indx_max) = II
16898C write partons to JETSET
16899 ELSE IF(NCODE(I).GE.0) THEN
16900 K1 = JMOHEP(1,NPOS(1,I))
16901 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16902 IJ = 0
16903 DO II=K1,K2
16904 IP = IP+1
16905 P(IP,1) = PHEP(1,II)
16906 P(IP,2) = PHEP(2,II)
16907 P(IP,3) = PHEP(3,II)
16908 P(IP,4) = PHEP(4,II)
16909 P(IP,5) = PHEP(5,II)
16910 K(IP,1) = 1
16911 K(IP,2) = IDHEP(II)
16912 K(IP,3) = 0
16913 K(IP,4) = 0
16914 K(IP,5) = 0
16915 IPHIST(2,II) = IP
16916 IJ = IJ+1
16917 IJOIN(IJ) = IP
16918 indx_max = indx_max+1
16919 indx(indx_max) = II
16920 ENDDO
16921 II = JMOHEP(2,NPOS(1,I))
16922 IF((II.GT.0).AND.(II.NE.K1)) THEN
16923 IP = IP+1
16924 P(IP,1) = PHEP(1,II)
16925 P(IP,2) = PHEP(2,II)
16926 P(IP,3) = PHEP(3,II)
16927 P(IP,4) = PHEP(4,II)
16928 P(IP,5) = PHEP(5,II)
16929 K(IP,1) = 1
16930 K(IP,2) = IDHEP(II)
16931 K(IP,3) = 0
16932 K(IP,4) = 0
16933 K(IP,5) = 0
16934 IPHIST(2,II) = IP
16935 IJ = IJ+1
16936 IJOIN(IJ) = IP
16937 indx_max = indx_max+1
16938 indx(indx_max) = II
16939 ENDIF
16940 N = IP
16941C connect partons to strings
16942 CALL PYJOIN(IJ,IJOIN)
16943 ENDIF
16944
16945 NPOS(4,I) = -NPOS(4,I)
16946 endif
16947 400 continue
16948
16949C set Lund counter
16950 N = IP
16951 if(IP.eq.0) goto 299
16952
16953C hard final state evolution
16954 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16955 ISH = 0
16956 do 125 k1=1,indx_max
16957 I = indx(k1)
16958 IF(IPHIST(1,I).LE.-100) THEN
16959 ISH = ISH+1
16960 IJOIN(ISH) = I
16961 ENDIF
16962 125 continue
16963 IF(ISH.GE.2) THEN
16964 DO 130 K1=1,ISH
16965 IF(IJOIN(K1).EQ.0) GOTO 130
16966 I = IJOIN(K1)
16967 IF((IPAMDL(102).EQ.1)
16968 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16969 DO 135 K2=K1+1,ISH
16970 IF(IJOIN(K2).EQ.0) GOTO 135
16971 II = IJOIN(K2)
16972 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16973 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16974 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16975 RQLUN = MIN(PT1,PT2)
16976 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16977 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16978 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16979 IJOIN(K1) = 0
16980 IJOIN(K2) = 0
16981 GOTO 130
16982 ENDIF
16983 135 CONTINUE
16984 130 CONTINUE
16985 ENDIF
16986 ENDIF
16987
16988C fragment parton / hadron configuration (hadronization & decay)
16989
16990 IF(ISWMDL(6).NE.0) THEN
16991 II = MSTU(21)
16992 MSTU(21) = 1
16993 CALL PYEXEC
16994 MSTU(21) = II
16995C Lund warning?
16996 if(MSTU(28).ne.0) then
16997 IF(IDEB(22).GE.10) THEN
16998 WRITE(LO,'(1X,A,I12,I3)')
16999 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
17000 & KEVENT,MSTU(28)
17001 CALL PHO_PREVNT(2)
17002 ENDIF
17003 endif
17004C event accepted?
17005 IF(MSTU(24).NE.0) THEN
17006 IF(IDEB(22).GE.2) THEN
17007 WRITE(LO,'(1X,A,I12,I3)')
17008 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17009 & KEVENT,MSTU(24)
17010 CALL PHO_PREVNT(2)
17011 ENDIF
17012 IREJ = 1
17013 RETURN
17014 ENDIF
17015 ENDIF
17016
17017 IP = N
17018C change particle status in JETSET to avoid internal adjustments
17019 do k1=IP_old,IP
17020 K(k1,1) = K(k1,1)+1000
17021 enddo
17022 IP_old = IP+1
17023
17024 299 continue
17025 300 CONTINUE
17026
17027C restore original JETSET particle status codes
17028 do i=1,N
17029 K(i,1) = K(i,1)-1000
17030 enddo
17031
17032* IF(IDEB(22).GE.25) THEN
17033* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17034* & 'particle/string system before fragmentation'
17035* CALL PHO_PREVNT(2)
17036* ENDIF
17037
17038C copy hadrons back to POEVT1 / POEVT2
17039
17040 IF(IP.GT.0) THEN
17041 NHEP1 = NHEP+1
17042 NLINES = PYK(0,1)
17043C copy hadrons back with full history information
17044 IF(IPAMDL(178).EQ.1) THEN
17045 DO 155 II=1,ISTR
17046 IF(NCODE(II).GE.0) THEN
17047 K1 = IPHIST(2,NPOS(2,II))
17048 K2 = IPHIST(2,-NPOS(3,II))
17049 ELSE IF(NCODE(II).EQ.-99) THEN
17050 K1 = IPHIST(2,NPOS(1,II))
17051 K2 = K1
17052 ELSE
17053 GOTO 149
17054 ENDIF
17055 IFOUND = 0
17056 DO 160 J=1,NLINES
17057 IF(PYK(J,7).EQ.1) THEN
17058 IPMOTH = PYK(J,15)
17059 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17060 IBAM = ipho_pdg2id(PYK(J,8))
17061 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17062 IF(IDEB(22).GE.2) THEN
17063 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17064 & 'LUND interface (1) rejection'
17065 CALL PHO_PREVNT(2)
17066 ENDIF
17067 IREJ = 1
17068 RETURN
17069 ENDIF
17070 IFOUND = IFOUND+1
17071 PX = PYP(J,1)
17072 PY = PYP(J,2)
17073 PZ = PYP(J,3)
17074 HE = PYP(J,4)
17075 XMB = PYP(J,5)**2
17076C register parton/hadron
17077 IS = 1
17078 IF(IBAM.EQ.0) THEN
17079 IF(ISWMDL(6).EQ.0) THEN
17080 IS = -1
17081 ELSE
17082 IF(IDEB(22).GE.2) THEN
17083 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17084 & 'LUND interface (2) rejection'
17085 CALL PHO_PREVNT(2)
17086 ENDIF
17087 IREJ = 1
17088 RETURN
17089 ENDIF
17090 ENDIF
17091 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17092 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17093 ISTHEP(IPOS) = 1
17094 ENDIF
17095 ENDIF
17096 160 CONTINUE
17097 IF(IFOUND.EQ.0) THEN
17098 IF(IDEB(2).GE.2) THEN
17099 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17100 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17101 ENDIF
17102 ISTHEP(NPOS(1,II)) = 2
17103 ENDIF
17104 149 CONTINUE
17105 155 CONTINUE
17106 ELSE
17107C copy hadrons back without history information
17108 JDAHEP(1,1) = NHEP1
17109 JDAHEP(1,2) = NHEP1
17110 DO 170 J=1,NLINES
17111 IF(PYK(J,7).EQ.1) THEN
17112 IBAM = ipho_pdg2id(PYK(J,8))
17113 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17114 IF(IDEB(22).GE.2) THEN
17115 WRITE(LO,'(/1X,A)')
17116 & 'PHO_STRFRA: LUND interface (3) rejection'
17117 CALL PHO_PREVNT(2)
17118 ENDIF
17119 IREJ = 1
17120 RETURN
17121 ENDIF
17122 PX = PYP(J,1)
17123 PY = PYP(J,2)
17124 PZ = PYP(J,3)
17125 HE = PYP(J,4)
17126 XMB = PYP(J,5)**2
17127C register parton/hadron
17128 IS = 1
17129 IF(IBAM.EQ.0) THEN
17130 IF(ISWMDL(6).EQ.0) THEN
17131 IS = -1
17132 ELSE
17133 IF(IDEB(22).GE.2) THEN
17134 WRITE(LO,'(/1X,A)')
17135 & 'PHO_STRFRA: LUND interface (4) rejection'
17136 CALL PHO_PREVNT(2)
17137 ENDIF
17138 IREJ = 1
17139 RETURN
17140 ENDIF
17141 ENDIF
17142 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17143 & HE,J,0,0,0,IPOS,1)
17144 ISTHEP(IPOS) = 1
17145 ENDIF
17146 170 CONTINUE
17147 DO 180 II=1,ISTR
17148 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17149 & ISTHEP(NPOS(1,II)) = 2
17150 180 CONTINUE
17151 ENDIF
17152 ENDIF
17153
17154C debug event status
17155 IF(IDEB(22).GE.15) THEN
17156 WRITE(LO,'(//1X,A)')
17157 & 'PHO_STRFRA: particle system after fragmentation'
17158 CALL PHO_PREVNT(2)
17159 ENDIF
17160
17161 END
17162
17163*$ CREATE PHO_EVEINI.FOR
17164*COPY PHO_EVEINI
17165CDECK ID>, PHO_EVEINI
17166 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17167C********************************************************************
17168C
17169C prepare /POEVT1/ for new event
17170C
17171C first subroutine called for each event
17172C
17173C input: P1(4) particle 1
17174C P2(4) particle 2
17175C IMODE 0 general initialization
17176C 1 initialization of particles and kinematics
17177C 2 initialization after internal rejection
17178C
17179C output: IP1,IP2 index of interacting particles
17180C
17181C********************************************************************
17182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17183 SAVE
17184
17185 DIMENSION P1(4),P2(4)
17186
17187 PARAMETER ( EPS = 1.D-5,
17188 & DEPS = 1.D-15 )
17189
17190C input/output channels
17191 INTEGER LI,LO
17192 COMMON /POINOU/ LI,LO
17193C event debugging information
17194 INTEGER NMAXD
17195 PARAMETER (NMAXD=100)
17196 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17197 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17198 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17199 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17200C model switches and parameters
17201 CHARACTER*8 MDLNA
17202 INTEGER ISWMDL,IPAMDL
17203 DOUBLE PRECISION PARMDL
17204 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17205C general process information
17206 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17207 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17208C gamma-lepton or gamma-hadron vertex information
17209 INTEGER IGHEL,IDPSRC,IDBSRC
17210 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17211 & RADSRC,AMSRC,GAMSRC
17212 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17213 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17214 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17215C global event kinematics and particle IDs
17216 INTEGER IFPAP,IFPAB
17217 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17218 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17219C energy-interpolation table
17220 INTEGER IEETA2
17221 PARAMETER ( IEETA2 = 20 )
17222 INTEGER ISIMAX
17223 DOUBLE PRECISION SIGTAB,SIGECM
17224 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17225C cross sections
17226 INTEGER IPFIL,IFAFIL,IFBFIL
17227 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17228 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17229 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17230 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17231 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17232 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17233 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17234 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17235 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17236 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17237 & IPFIL,IFAFIL,IFBFIL
17238C color string configurations including collapsed strings and hadrons
17239 INTEGER MSTR
17240 PARAMETER (MSTR=500)
17241 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17242 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17243 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17244 & NNCH(MSTR),IBHAD(MSTR),ISTR
17245C standard particle data interface
17246 INTEGER NMXHEP
17247 PARAMETER (NMXHEP=4000)
17248 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17249 DOUBLE PRECISION PHEP,VHEP
17250 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17251 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17252 & VHEP(4,NMXHEP)
17253C extension to standard particle data interface (PHOJET specific)
17254 INTEGER IMPART,IPHIST,ICOLOR
17255 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17256C table of particle indices for recursive PHOJET calls
17257 INTEGER MAXIPX
17258 PARAMETER ( MAXIPX = 100 )
17259 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17260 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17261 & IPOIX1,IPOIX2,IPOIX3
17262C event weights and generated cross section
17263 INTEGER IPOWGC,ISWCUT,IVWGHT
17264 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17265 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17266 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17267
17268 DIMENSION IM(2)
17269
17270C reset debug variables
17271 KSPOM = 0
17272 KHPOM = 0
17273 KSREG = 0
17274 KHDIR = 0
17275 KSTRG = 0
17276 KHTRG = 0
17277 KSLOO = 0
17278 KHLOO = 0
17279 KSDPO = 0
17280 KSOFT = 0
17281 KHARD = 0
17282C
17283 IDNODF = 0
17284 IDIFR1 = 0
17285 IDIFR2 = 0
17286 IDDPOM = 0
17287 ISTR = 0
17288 IPOIX1 = 0
17289 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17290 IPOIX2 = 0
17291 IPOIX3 = 0
17292C reset /POEVT1/ and /POEVT2/
17293 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17294 & 0,0,0,0,IPOS,0)
17295 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17296 DO 15 I=0,10
17297 IPOWGC(I) = 0
17298 15 CONTINUE
17299
17300C initialization of particle kinematics
17301
17302C lepton-photon/hadron-photon vertex and initial particles
17303 IM(1) = 0
17304 IM(2) = 0
17305 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17306 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17307 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17308 ELSE
17309 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17310 & P1(4),0,0,0,0,IP1,1)
17311 ENDIF
17312 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17313 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17314 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17315 ELSE
17316 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17317 & P2(4),0,0,0,0,IP2,1)
17318 ENDIF
17319 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17320 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17321 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17322 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17323 & P1(4),0,0,0,0,IP1,1)
17324 ENDIF
17325 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17326 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17327 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17328 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17329 & P2(4),0,0,0,0,IP2,1)
17330 ENDIF
17331 NEVHEP = KACCEP
17332
17333 IF(IMODE.LE.1) THEN
17334C CMS energy
17335 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17336 & -(P1(3)+P2(3))**2)
17337* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17338 PMASS(1) = PHEP(5,IP1)
17339 PVIRT(1) = 0.D0
17340 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17341 PMASS(2) = PHEP(5,IP2)
17342 PVIRT(2) = 0.D0
17343 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17344 ENDIF
17345
17346C cross section calculations
17347
17348 IF(IMODE.NE.1) THEN
17349 IP = 1
17350 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17351 & ECM,PVIRT(1),PVIRT(2))
17352 ENDIF
17353
17354 IF(IMODE.LE.0) THEN
17355C effective cross section
17356 SIGGEN(3) = 0.D0
17357 IF(ISWMDL(2).ge.1) THEN
17358 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17359 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17360 & -SIGHDD-SIGDIR
17361 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17362 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17363 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17364 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17365 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17366 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17367 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17368C simulate only hard scatterings
17369 ELSE
17370 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17371 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17372 ENDIF
17373
17374 ENDIF
17375
17376C reset of mother/daughter relations only (IMODE = 2)
17377
17378C debug output
17379 IF(IDEB(63).GE.15) THEN
17380 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17381 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17382 IF(IMODE.LE.0) THEN
17383 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17384 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17385 & FSUP,FSUH,FSUD
17386 ONEM = -1.D0
17387 ITMP = IDEB(57)
17388 IDEB(57) = MAX(5,ITMP)
17389 CALL PHO_XSECT(1,0,ONEM)
17390 IDEB(57) = ITMP
17391 ENDIF
17392 CALL PHO_PREVNT(0)
17393 ENDIF
17394
17395 END
17396
17397*$ CREATE PHO_CSINT.FOR
17398*COPY PHO_CSINT
17399CDECK ID>, PHO_CSINT
17400 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17401C********************************************************************
17402C
17403C calculate cross sections by interpolation
17404C
17405C input: IP particle combination
17406C IFPA/B particle PDG number
17407C IHLA/B particle helicity (photons only)
17408C ECM c.m. energy (GeV)
17409C PVIR2A virtuality of particle A (GeV**2, positive)
17410C PVIR2B virtuality of particle B (GeV**2, positive)
17411C
17412C output: cross sections stored in /POCSEC/
17413C
17414C********************************************************************
17415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17416 SAVE
17417
17418 PARAMETER ( EPS = 1.D-5,
17419 & DEPS = 1.D-15 )
17420
17421C input/output channels
17422 INTEGER LI,LO
17423 COMMON /POINOU/ LI,LO
17424C some constants
17425 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17426 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17427 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17428C event debugging information
17429 INTEGER NMAXD
17430 PARAMETER (NMAXD=100)
17431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17435C model switches and parameters
17436 CHARACTER*8 MDLNA
17437 INTEGER ISWMDL,IPAMDL
17438 DOUBLE PRECISION PARMDL
17439 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17440C energy-interpolation table
17441 INTEGER IEETA2
17442 PARAMETER ( IEETA2 = 20 )
17443 INTEGER ISIMAX
17444 DOUBLE PRECISION SIGTAB,SIGECM
17445 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17446C cross sections
17447 INTEGER IPFIL,IFAFIL,IFBFIL
17448 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17449 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17450 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17451 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17452 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17453 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17454 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17455 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17456 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17457 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17458 & IPFIL,IFAFIL,IFBFIL
17459C hard cross sections and MC selection weights
17460 INTEGER Max_pro_2
17461 PARAMETER ( Max_pro_2 = 16 )
17462 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17463 & MH_acc_1,MH_acc_2
17464 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17465 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17466 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17467 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17468 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17469 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17470
17471 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17472
17473 dimension PD(-6:6),FH_T(2),FH_L(2)
17474
17475C debug
17476 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17477 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17478 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17479
17480C check currently stored cross sections
17481 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17482 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17483 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17484C nothing to calculate
17485 IF(IDEB(15).GE.20)
17486 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17487 RETURN
17488 ELSE
17489
17490C copy to local fields
17491 IFPAP(1) = IFPA
17492 IFPAP(2) = IFPB
17493 IHEL(1) = IHLA
17494 IHEL(2) = IHLB
17495 PVIRT(1) = PVIR2A
17496 PVIRT(2) = PVIR2B
17497
17498C load cross sections from interpolation table
17499 IF(ECM.LE.SIGECM(IP,1)) THEN
17500 I1 = 1
17501 I2 = 2
17502 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17503 DO 50 I=2,ISIMAX
17504 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17505 50 CONTINUE
17506 200 CONTINUE
17507 I1 = I-1
17508 I2 = I
17509 ELSE
17510 WRITE(LO,'(/1X,A,2E12.3)')
17511 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17512 CALL PHO_PREVNT(-1)
17513 I1 = ISIMAX-1
17514 I2 = ISIMAX
17515 ENDIF
17516 FAC2=0.D0
17517 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17518 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17519 FAC1=1.D0-FAC2
17520
17521C cross section dependence on photon virtualities
17522 DO 140 K=1,2
17523 FSUP(K) = 1.D0
17524 FSUD(K) = 1.D0
17525 FSUH(K) = 1.D0
17526 IF(IFPAP(K).EQ.22) THEN
17527 IF(ISWMDL(10).GE.1) THEN
17528 FSUP(K) = 0.D0
17529 FSUT(K) = 0.D0
17530 FSUL(K) = 0.D0
17531 FSUH(K) = 0.D0
17532C GVDM factors for transverse/longitudinal photons
17533 DO 150 I=1,3
17534 FSUT(K) = FSUT(K)+PARMDL(26+I)
17535 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17536 FSUL(K) = FSUL(K)
17537 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17538 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17539 150 CONTINUE
17540 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17541C transverse part
17542 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17543 FSUP(K) = FSUT(K)
17544 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17545C diffraction of trans. photons corresponds mainly to leading twist
17546 FSUD(K) = 1.D0
17547 ENDIF
17548C longitudinal (scalar) part
17549 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17550 FSUP(K) = FSUP(K)+FSUL(K)
17551 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17552C diffraction of long. photons corresponds mainly to higher twist
17553 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17554 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17555 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17556 ENDIF
17557C debug output
17558 if(ideb(15).ge.10) then
17559 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17560 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17561 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17562 endif
17563 ENDIF
17564 ENDIF
17565 140 CONTINUE
17566
17567 FACP = FSUP(1)*FSUP(2)
17568 FACH = FSUH(1)*FSUH(2)
17569 FACD = FSUD(1)*FSUD(2)
17570
17571C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17572
17573 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17574 & .and.(IPAMDL(117).gt.0)) then
17575C check kinematic limit
17576 Q2_max = max(PVIRT(1),PVIRT(2))
17577 Q2_min = min(PVIRT(1),PVIRT(2))
17578 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17579
17580C calculate F2 from current parton density
17581 if(PVIRT(1).gt.PVIRT(2)) then
17582 K = 2
17583 else
17584 K = 1
17585 endif
17586 Q2 = Q2_max
17587 P2 = Q2_min
17588 X = Q2/(ECM**2+Q2+P2)
17589 call pho_actpdf(IFPAP(K),K)
17590 call pho_pdf(K,X,Q2,P2,PD)
17591C light quark contribution
17592 F2_light = 0.D0
17593 do j=1,3
17594 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17595 enddo
17596C heavy quark contribution
17597 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17598 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17599 F2 = (F2_light+F2_c)
17600
17601C calculate model prediction
17602 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17603 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17604 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17605
17606 if(ISWMDL(10).ge.2) then
17607
17608C calculate all helicity combinations
17609 if(IPAMDL(115).eq.0) then
17610 SIGDIH = HSig(14)
17611 SIGSRH(1) = HSig(10)+HSig(11)
17612 SIGSRH(2) = HSig(12)+HSig(13)
17613 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17614C photon helicity factors
17615 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17616 FH_L(1) = 1.D0-FH_T(1)
17617 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17618 FH_L(2) = 1.D0-FH_T(2)
17619 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17620 & + SIGDIH*FH_T(1)*FH_T(2)
17621 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17622 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17623 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17624 & + SIGDIH*FH_T(1)*FH_L(2)
17625 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17626 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17627 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628 & + SIGDIH*FH_L(1)*FH_T(2)
17629 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17630 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17631 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17632 & + SIGDIH*FH_L(1)*FH_L(2)
17633 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17634 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17635 else
17636C use explicit PDF virtuality dependence (pre-tabulated)
17637 SIGDIH = HSig(14)
17638 SIGSRH(1) = HSig(10)+HSig(11)
17639 SIGSRH(2) = HSig(12)+HSig(13)
17640 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
ecf67adb 17641 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
9aaba0d6 17642 stop
17643* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17644* & Max_pro_2,3,4,1)
17645* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17646* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17647* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17648* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17649* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17650* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17651* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17652* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17653 endif
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 if(K.eq.2) then
17658 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17659 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17660 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17661 else
17662 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17663 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17664 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17665 endif
17666
17667 else
17668
17669C assume sig_eff = sigtot
17670 SIGDIH = HSig(14)
17671 SIGSRH(1) = HSig(10)+HSig(11)
17672 SIGSRH(2) = HSig(12)+HSig(13)
17673 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17674 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17675 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17676 Xnu = Ecm*Ecm+Q2+P2
17677 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17678 & *137.D0/GeV2mb
17679 F2m = F2_fac*SIGeff
17680 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17681 endif
ecf67adb 17682* WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17683* WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
9aaba0d6 17684
17685C global factor to re-scale suppression of soft contributions
17686 Fcorr = (F2-F2m+F2s)/F2s
ecf67adb 17687* WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
9aaba0d6 17688 FACP = FACP*Fcorr
17689
17690 endif
17691 endif
17692
17693 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17694 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17695 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17696 J = 2
17697 DO 5 I=0,4
17698 DO 6 K=0,4
17699 J = J+1
17700 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17701 & *FACP**2
17702 6 CONTINUE
17703 5 CONTINUE
17704
17705 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17706 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17707C suppression of multi-pomeron graphs (diffraction)
17708 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17709 & *FACP*FSUP(2)*FSUD(1)
17710 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17711 & *FACP*FSUP(1)*FSUD(2)
17712 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17713 & *FACP*FSUP(2)*FSUD(1)
17714 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17715 & *FACP*FSUP(1)*FSUD(2)
17716 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17717 & *FACP**2*FACD
17718 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17719 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17720 & *FACP**2
17721 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17722 & *FACP*FSUP(2)*FSUD(1)
17723 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17724 & *FACP*FSUP(2)*FSUD(1)
17725 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17726 & *FACP*FSUP(1)*FSUD(2)
17727 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17728 & *FACP*FSUP(1)*FSUD(2)
17729 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17730 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17731 & *FACP**2
17732 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17733 & *FACP**2
17734 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17735 & *FACP**2
17736 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17737 & *FACP**2
17738
17739C corrections due to photon virtuality dependence of PDFs
17740 if(iswmdl(2).eq.1) then
17741 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17742C minimum bias event generation
17743 IF(IPAMDL(115).GE.1) THEN
17744C all the virtuality dependence is given by PDF parametrization
17745 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17746 IF(IPAMDL(116).GE.2) THEN
17747C direct interaction according to full QPM calculation
17748 SIGDIH = HSig(14)
17749 SIGSRH(1) = HSig(10)+HSig(11)
17750 SIGSRH(2) = HSig(12)+HSig(13)
17751 ELSE
17752C direct interaction suppressed according to helicity factor
17753 SIGDIH = HSig(14)*FACH
17754 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17755 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17756 ENDIF
ecf67adb 17757 WRITE(LO,*) ' PHO_CSINT: option not supported yet'
9aaba0d6 17758 stop
17759 ELSE
17760C rescale relevant hard processes
17761 SIGDIH = HSig(14)
17762 SIGSRH(1) = HSig(10)+HSig(11)
17763 SIGSRH(2) = HSig(12)+HSig(13)
17764 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17765 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17766 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17767 SIGINE = SIGtmp+SIGDIR
17768 SIGTOT = SIGINE+SIGELA
17769 ENDIF
17770 else
17771C only hard interactions
17772 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17773 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17774 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17775 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17776 SIGHAR = HSig(9)*FACH
17777 endif
17778
17779 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17780 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17781 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17782 J = 39
17783 DO 9 I=1,4
17784 DO 10 K=1,4
17785 J = J+1
17786 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17787 10 CONTINUE
17788 9 CONTINUE
17789 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17790 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17791
17792 IPFIL = IP
17793 IFAFIL = IFPA
17794 IFBFIL = IFPB
17795 ECMFIL = ECM
17796 P2AFIL = PVIR2A
17797 P2BFIL = PVIR2B
17798
17799 IF(IDEB(15).GE.20)
17800 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17801
17802 ENDIF
17803
17804 END
17805
17806*$ CREATE PHO_PRIMKT.FOR
17807*COPY PHO_PRIMKT
17808CDECK ID>, PHO_PRIMKT
17809 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17810C***********************************************************************
17811C
17812C give primordial kt to partons entering hard scatterings and
17813C remants connected to hard parton-parton interactions by color flow
17814C
17815C input: IMODE -2 output of statistics
17816C -1 initialization
17817C 1 sampling of primordial kt
17818C IF first entry in /POEVT1/ to check
17819C IL last entry in /POEVT1/ to check
17820C PTCUT current value of PTCUT to distinguish
17821C between soft and hard
17822C
17823C output: IREJ 0 success
17824C 1 failure
17825C
17826C***********************************************************************
17827 IMPLICIT NONE
17828 SAVE
17829
17830 DOUBLE PRECISION DEPS
17831 PARAMETER ( DEPS = 1.D-15 )
17832
17833 INTEGER IMODE,IF,IL,IREJ
17834 DOUBLE PRECISION PTCUT
17835
17836C input/output channels
17837 INTEGER LI,LO
17838 COMMON /POINOU/ LI,LO
17839C event debugging information
17840 INTEGER NMAXD
17841 PARAMETER (NMAXD=100)
17842 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17843 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17844 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17845 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17846C model switches and parameters
17847 CHARACTER*8 MDLNA
17848 INTEGER ISWMDL,IPAMDL
17849 DOUBLE PRECISION PARMDL
17850 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17851C some constants
17852 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17853 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17854 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17855C data of c.m. system of Pomeron / Reggeon exchange
17856 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17857 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17858 & SIDP,CODP,SIFP,COFP
17859 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17860 & SIDP,CODP,SIFP,COFP,NPOSP(2),
17861 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
17862C hard scattering data
17863 INTEGER MSCAHD
17864 PARAMETER ( MSCAHD = 50 )
17865 INTEGER LSCAHD,LSC1HD,LSIDX,
17866 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17867 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17868 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17869 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17870 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17871 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17872 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17873 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17874 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17875C standard particle data interface
17876 INTEGER NMXHEP
17877 PARAMETER (NMXHEP=4000)
17878 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17879 DOUBLE PRECISION PHEP,VHEP
17880 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17881 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17882 & VHEP(4,NMXHEP)
17883C extension to standard particle data interface (PHOJET specific)
17884 INTEGER IMPART,IPHIST,ICOLOR
17885 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17886
17887 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17888 DIMENSION PTS(0:2,5),XP(5),
17889 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17890
17891 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17892
17893 PARAMETER (IRMAX=200)
17894 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17895
17896 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17897 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17898 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17899
17900C debug output
17901 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17902 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17903 & IMODE,IF,IL,PTCUT
17904
17905C give primordial kt to partons engaged in a hard scattering
17906
17907 IF(IMODE.EQ.1) THEN
17908
17909 ISTART = IF
17910
17911 100 CONTINUE
17912
17913 NHD = 0
17914 IBAL(1) = 0
17915 IBAL(2) = 0
17916 IROT = 0
17917 ICOM = 0
17918 DO 110 I=ISTART,IL
17919 IF(ISTHEP(I).EQ.25) THEN
17920C hard scattering number
17921 NHD = IPHIST(1,I+1)
17922 ICOM = I
17923 K = LSIDX(NHD/100)
17924C calculate momenta of incoming partons
17925 POLD(1,1) = XHD(K,1)*ECMP/2.D0
17926 POLD(2,1) = POLD(1,1)
17927 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17928 POLD(2,2) = -POLD(1,2)
17929 ISTART = I+3
17930 GOTO 150
17931 ENDIF
17932 110 CONTINUE
17933 RETURN
17934
17935 150 CONTINUE
17936
17937C search for partons involved in hard interaction
17938 INEXT = 0
17939 IROT = 0
17940 DO 500 I=ISTART,IL
17941 IF(ABS(ISTHEP(I)).EQ.1) THEN
17942C hard scatterd partons (including ISR)
17943 IF((IPHIST(1,I).EQ.-NHD)
17944 & .OR.(IPHIST(1,I).EQ.NHD+1)
17945 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17946 IROT = IROT+1
17947 IF(IROT.GT.IRMAX) THEN
17948 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17949 & 'no memory left in IROTT, event rejected (max/IROT)',
17950 & IRMAX,IROT
17951 CALL PHO_PREVNT(0)
17952 IREJ = 1
17953 RETURN
17954 ENDIF
17955 IROTT(IROT) = I
17956C hard remnant
17957 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17958 IF(PHEP(3,I).GT.0.D0) THEN
17959 J = 1
17960 ELSE
17961 J = 2
17962 ENDIF
17963 IBAL(J) = IBAL(J)+1
17964 IBALT(IBAL(J),J) = I
17965 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17966 IF(ISWMDL(24).EQ.0) THEN
17967 IV2(IBAL(J),J) = 0
17968 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17969 ELSE IF(ISWMDL(24).EQ.1) THEN
17970 IV2(IBAL(J),J) = -1
17971 ELSE
17972 IV2(IBAL(J),J) = 1
17973 ENDIF
17974 ENDIF
17975C possibly further hard scattering
17976 ELSE IF(ISTHEP(I).EQ.25) THEN
17977 INEXT = 1
17978 ISTART = I
17979 GOTO 550
17980 ENDIF
17981 500 CONTINUE
17982 550 CONTINUE
17983
17984C debug output
17985 if(IDEB(10).ge.15) then
17986 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17987 & 'hard scattering number: ',NHD/100
17988 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17989 & 'number of entries to rotate: ',IROT
17990 DO I=1,IROT
17991 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17992 & 'entries to rotate: ',I,IROTT(I)
17993 ENDDO
17994 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17995 & 'number of entries to balance: ',IBAL
17996 DO J=1,2
17997 DO I=1,IBAL(J)
17998 WRITE(LO,'(1X,2A,I2,2I5)')
17999 & 'PHO_PRIMKT: entries to balance (side,no,line)',
18000 & J,I,IBALT(I,J)
18001 ENDDO
18002 ENDDO
18003 endif
18004
18005C incoming partons (comment lines), skip direct interacting particles
18006 DO 120 K=1,2
18007 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18008 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18009 J = 1
18010 ELSE
18011 J = 2
18012 ENDIF
18013 IBAL(J) = IBAL(J)+1
18014 IBALT(IBAL(J),J) = -ICOM-K
18015 XP2(IBAL(J),J) = POLD(1,J)/ECMP
18016 IV2(IBAL(J),J) = -1
18017 ENDIF
18018 120 CONTINUE
18019
18020C check consistency
18021 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18022 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18023 & 'inconsistent hard scattering remnant for event: ',KEVENT
18024 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18025 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18026 & IMODE,IF,IL,PTCUT
18027 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18028 DO 390 I=1,IROT
18029 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18030 390 CONTINUE
18031 DO 392 J=1,2
18032 DO 395 I=1,IBAL(J)
18033 WRITE(LO,'(1X,A,I2,2I5)')
18034 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18035 395 CONTINUE
18036 392 CONTINUE
18037 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18038 ENDIF
18039
18040C calculate primordial kt
18041
18042C something to do?
18043 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18044
18045C add transverse momentum (overwrite /POEVT1/ entries)
18046 DO 200 J=1,2
18047 IF(IBAL(J).GT.1) THEN
18048C sample from truncated distribution
18049 K = IBAL(J)
18050 DO 180 I=1,K
18051 IV(I) = IV2(I,J)
18052 XP(I) = XP2(I,J)
18053 180 CONTINUE
18054 190 CONTINUE
18055 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18056 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18057C transform incoming partons of hard scattering
18058 DEL = ABS(POLD(1,J))+POLD(2,J)
18059 PT2 = PTS(0,K)**2
18060 DEL2 = DEL*DEL
18061 PNEW(1,J) = PTS(1,K)
18062 PNEW(2,J) = PTS(2,K)
18063 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18064 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18065C spectator partons
18066 ESUM = 0.D0
18067 DO 220 I=1,IBAL(J)-1
18068 K = IBALT(I,J)
18069 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18070 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18071 ESUM = ESUM+PHEP(4,K)
18072 220 CONTINUE
18073C long. momentum transfer
18074 PP(3) = PNEW(3,J) - POLD(1,J)
18075 PP(4) = PNEW(4,J) - POLD(2,J)
18076 DO 230 I=1,IBAL(J)-1
18077 K = IBALT(I,J)
18078 FAC = PHEP(4,K)/ESUM
18079 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18080 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18081 230 CONTINUE
18082
18083C debug output
18084 IF(IDEB(10).GE.15) THEN
18085 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18086 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18087 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18088 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18089 ENDIF
18090
18091 ELSE
18092 PNEW(1,J) = 0.D0
18093 PNEW(2,J) = 0.D0
18094 PNEW(3,J) = POLD(1,J)
18095 PNEW(4,J) = POLD(2,J)
18096 ENDIF
18097 200 CONTINUE
18098
18099C transformation of hard scattering final states (including ISR)
18100
18101C old parton c.m. energy
18102 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18103 EI = SQRT(SI)
18104C new parton c.m. energy
18105 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18106 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18107 EF = SQRT(SF)
18108 FAC = EF/EI
18109C debug output
18110 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18111 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18112
18113C calculate Lorentz transformation
18114 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18115 GAE = (POLD(2,1)+POLD(2,2))/EI
18116 DO 240 I=1,4
18117 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18118 240 CONTINUE
18119 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18120 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18121 PTOT = MAX(DEPS,PTOT)
18122 COD= PP(3)/PTOT
18123 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18124 COF= 1.D0
18125 SIF= 0.D0
18126 IF(PTOT*SID.GT.1.D-5) THEN
18127 COF=PP(1)/(SID*PTOT)
18128 SIF=PP(2)/(SID*PTOT)
18129 ANORF=SQRT(COF*COF+SIF*SIF)
18130 COF=COF/ANORF
18131 SIF=SIF/ANORF
18132 ENDIF
18133
18134C debug output
18135C check consistency initial/final configuration before rotation
18136 IF(IDEB(10).GE.25) THEN
18137 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18138 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18139 DO I=1,4
18140 PP(I) = 0.D0
18141 ENDDO
18142 DO I=1,IROT
18143 K = IROTT(I)
18144 DO J=1,4
18145 PP(J) = PP(J)+PHEP(J,K)
18146 ENDDO
18147 ENDDO
18148 WRITE(LO,'(1X,A,1P,4E11.3)')
18149 & 'PHO_PRIMKT: fin. momentum (1):',PP
18150 ENDIF
18151
18152C apply rotation/boost to scattered particles
18153 DO 400 I=1,IROT
18154 K = IROTT(I)
18155 DO 350 J=1,4
18156 PP(J) = FAC*PHEP(J,K)
18157 350 CONTINUE
18158 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18159 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18160 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18161 & COD,SID,COF,SIF,XX,YY,ZZ)
18162 EE = PHEP(4,K)
18163 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18164 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18165 400 CONTINUE
18166
18167C debug output
18168C check consistency initial/final configuration after rotation
18169 IF(IDEB(10).GE.25) THEN
18170 DO I=1,4
18171 PP(I) = PNEW(I,1)+PNEW(I,2)
18172 ENDDO
18173 WRITE(LO,'(1X,A,1P,4E11.3)')
18174 & 'PHO_PRIMKT: ini. momentum (2):',PP
18175 DO I=1,4
18176 PP(I) = 0.D0
18177 ENDDO
18178 DO I=1,IROT
18179 K = IROTT(I)
18180 DO J=1,4
18181 PP(J) = PP(J)+PHEP(J,K)
18182 ENDDO
18183 ENDDO
18184 WRITE(LO,'(1X,A,1P,4E11.3)')
18185 & 'PHO_PRIMKT: fin. momentum (2):',PP
18186 ENDIF
18187
18188 ENDIF
18189
18190 IF(INEXT.EQ.1) GOTO 100
18191
18192C initialization
18193
18194 ELSE IF(IMODE.EQ.-1) THEN
18195
18196C output of statistics etc.
18197
18198 ELSE IF(IMODE.EQ.-2) THEN
18199
18200C something wrong
18201
18202 ELSE
18203 WRITE(LO,'(/1X,A,I4)')
18204 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18205 CALL PHO_ABORT
18206 ENDIF
18207
18208 END
18209
18210*$ CREATE PHO_PARTPT.FOR
18211*COPY PHO_PARTPT
18212CDECK ID>, PHO_PARTPT
18213 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18214C********************************************************************
18215C
18216C assign to soft partons
18217C
18218C input: IMODE -2 output of statistics
18219C -1 initialization
18220C 0 sampling of pt for soft partons belonging to
18221C soft Pomerons
18222C 1 sampling of pt for soft partons belonging to
18223C hard Pomerons
18224C IF first entry in /POEVT1/ to check
18225C IL last entry in /POEVT1/ to check
18226C PTCUT current value of PTCUT to distinguish
18227C between soft and hard
18228C
18229C output: IREJ 0 success
18230C 1 failure
18231C
18232C (soft pt is sampled by call to PHO_SOFTPT)
18233C
18234C********************************************************************
18235 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18236 SAVE
18237
18238 PARAMETER ( DEPS = 1.D-15 )
18239
18240 INTEGER IMODE,IF,IL,IREJ
18241 DOUBLE PRECISION PTCUT
18242
18243C input/output channels
18244 INTEGER LI,LO
18245 COMMON /POINOU/ LI,LO
18246C event debugging information
18247 INTEGER NMAXD
18248 PARAMETER (NMAXD=100)
18249 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18250 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18251 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18252 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18253C model switches and parameters
18254 CHARACTER*8 MDLNA
18255 INTEGER ISWMDL,IPAMDL
18256 DOUBLE PRECISION PARMDL
18257 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18258C some constants
18259 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18260 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18261 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18262C data of c.m. system of Pomeron / Reggeon exchange
18263 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18264 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18265 & SIDP,CODP,SIFP,COFP
18266 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18267 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18268 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18269C standard particle data interface
18270 INTEGER NMXHEP
18271 PARAMETER (NMXHEP=4000)
18272 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18273 DOUBLE PRECISION PHEP,VHEP
18274 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18275 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18276 & VHEP(4,NMXHEP)
18277C extension to standard particle data interface (PHOJET specific)
18278 INTEGER IMPART,IPHIST,ICOLOR
18279 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18280
18281 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18282 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18283
18284 INTEGER MODIFY,IV,IVB
18285 DIMENSION MODIFY(50),IV(50),IVB(2)
18286
18287C debug output
18288 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18289 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18290 & IMODE,IF,IL,PTCUT
18291
18292 IF(IMODE.LT.0) GOTO 1000
18293
18294 IREJ = 0
18295 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18296
18297C count entries to modify
18298 IENTRY = 0
18299 PTCUT2 = PTCUT**2
18300 EMIN = 1.D20
18301 IPEAK = 1
18302 ISTART = IF
18303
18304C soft Pomerons
18305
18306 IF(IMODE.EQ.0) THEN
18307 DO 300 I=ISTART,IL
18308 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18309 IENTRY = IENTRY+1
18310 MODIFY(IENTRY) = I
18311 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18312 IV(IENTRY) = 0
18313 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18314 IF(PHEP(4,I).LT.EMIN) THEN
18315 EMIN = PHEP(4,I)
18316 IPEAK = IENTRY
18317 ENDIF
18318 ENDIF
18319 300 CONTINUE
18320
18321C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18322
18323 ELSE IF(IMODE.EQ.1) THEN
18324
18325 DO 350 I=ISTART,IL
18326 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18327 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18328 IENTRY = IENTRY+1
18329 MODIFY(IENTRY) = I
18330 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18331 IF(ISWMDL(24).EQ.0) THEN
18332 IV(IENTRY) = 0
18333 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18334 ELSE IF(ISWMDL(24).EQ.1) THEN
18335 IV(IENTRY) = -1
18336 ELSE
18337 IV(IENTRY) = 1
18338 ENDIF
18339 IF(PHEP(4,I).LT.EMIN) THEN
18340 EMIN = PHEP(4,I)
18341 IPEAK = IENTRY
18342 ENDIF
18343 ENDIF
18344 ENDIF
18345 350 CONTINUE
18346
18347C something wrong
18348
18349 ELSE
18350 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18351 CALL PHO_ABORT
18352 ENDIF
18353
18354C debug output
18355 IF(IDEB(6).GE.5) THEN
18356 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18357 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18358 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18359 ENDIF
18360
18361C nothing to do
18362 IF(IENTRY.LE.1) RETURN
18363
18364C sample pt of soft partons
18365
18366 IF(ISWMDL(5).LE.1) THEN
18367 ITER = 0
18368 IPEAK = DT_RNDM(DUM)*IENTRY+1
18369 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18370 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18371 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18372 400 CONTINUE
18373C energy limited sampling
18374 PSUMX = 0.D0
18375 PSUMY = 0.D0
18376 ITER = ITER+1
18377 IF(ITER.GE.1000) THEN
18378 IF(IDEB(6).GE.3) THEN
18379 WRITE(LO,'(1X,A,3I5)')
18380 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18381 & IMODE,IENTRY,ITER
18382 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18383 & IPEAK
18384 DO 405 I=1,IENTRY
18385 II = MODIFY(I)
18386 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18387 & I,II,IV(I),XP(I),PHEP(4,II)
18388 405 CONTINUE
18389 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18390 ENDIF
18391 IREJ = 1
18392 RETURN
18393 ENDIF
18394 DO 410 I=2,IENTRY
18395 II = MODIFY(I)
18396 PTMX = MIN(PHEP(4,II),PTCUT)
18397 XPB(1) = XP(I)
18398 IVB(1) = IV(I)
18399 IF(ISWMDL(5).EQ.0) THEN
18400 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18401 ELSE
18402 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18403 ENDIF
18404 PTS(0,I) = PB(0,1)
18405 PTS(1,I) = PB(1,1)
18406 PTS(2,I) = PB(2,1)
18407 PSUMX = PSUMX+PB(1,1)
18408 PSUMY = PSUMY+PB(2,1)
18409 410 CONTINUE
18410 PTREM = SQRT(PSUMX**2+PSUMY**2)
18411 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18412 PTS(1,1) = -PSUMX
18413 PTS(2,1) = -PSUMY
18414 ELSE IF((ISWMDL(5).EQ.2)
18415 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18416C unlimited sampling
18417 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18418 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18419 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18420 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18421 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18422 ELSE IF(ISWMDL(5).EQ.3) THEN
18423C each string has balanced pt
18424 DO 500 K=1,IENTRY
18425 IF(IV(K).LE.-90) GOTO 499
18426 I1 = MODIFY(K)
18427 IC1 = -ICOLOR(1,I1)
18428 DO 510 L=K+1,IENTRY
18429 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18430 510 CONTINUE
18431 WRITE(LO,'(//1X,A,I5)')
18432 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18433 CALL PHO_ABORT
18434 511 CONTINUE
18435 I2 = MODIFY(L)
18436 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18437 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18438 AM = SQRT(AMSQR)
18439 PTMX = AM/2.D0
18440 IVB(1) = MAX(IV(K),IV(L))
18441 XPB(1) = XP(K)
18442 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18443 PTS(1,K) = PB(1,1)
18444 PTS(2,K) = PB(2,1)
18445 PTS(1,L) = -PB(1,1)
18446 PTS(2,L) = -PB(2,1)
18447 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18448 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18449 PC(1) = PB(1,1)
18450 PC(2) = PB(2,1)
18451 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18452 PC(3) = SIGN(PLONG,PHEP(3,I1))
18453 PC(4) = PTMX
18454 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18455 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18456 PC(1) = -PC(1)
18457 PC(2) = -PC(2)
18458 PC(3) = -PC(3)
18459 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18460 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18461 IV(K) = IV(K)-100
18462 IV(L) = IV(L)-100
18463 499 CONTINUE
18464 500 CONTINUE
18465 ELSE
18466 WRITE(LO,'(/1X,A,I4)')
18467 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18468 CALL PHO_ABORT
18469 ENDIF
18470
18471C change partons in /POEVT1/
18472 DO 900 II=1,IENTRY
18473 IF(IV(II).GT.-90) THEN
18474 I = MODIFY(II)
18475 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18476 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18477 AMSQR = PHEP(4,I)**2
18478 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18479 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18480 ENDIF
18481 900 CONTINUE
18482
18483C debug output
18484 IF(IDEB(6).GE.15) THEN
18485 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18486 & 'I II IV XP EP PTS PTX PTY',IPEAK
18487 DO 505 I=1,IENTRY
18488 II = MODIFY(I)
18489 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18490 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18491 505 CONTINUE
18492 CALL PHO_PREVNT(0)
18493 ENDIF
18494 RETURN
18495
18496C initialization / output of statistics
18497 1000 CONTINUE
18498 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18499
18500 END
18501
18502*$ CREATE PHO_SOFTPT.FOR
18503*COPY PHO_SOFTPT
18504CDECK ID>, PHO_SOFTPT
18505 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18506C***********************************************************************
18507C
18508C select pt of soft string ends
18509C
18510C input: ISOFT number of soft partons
18511C -1 initialization
18512C >=0 sampling of p_t
18513C -2 output of statistics
18514C PTCUT cutoff for soft strings
18515C PTMAX maximal allowed PT
18516C XV field of x values
18517C IV 0 sea quark
18518C 1 valence quark
18519C
18520C output: /POINT3/ containing parameters AAS,BETAS
18521C PTSOF filed with soft pt values
18522C
18523C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18524C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18525C ISWMDL(3/4) = 2 photon wave function
18526C ISWMDL(3/4) = 10 no soft P_t assignment
18527C
18528C***********************************************************************
18529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18530 SAVE
18531
18532 PARAMETER ( DEPS = 1.D-15)
18533
18534 DIMENSION PTSOF(0:2,*),XV(*)
18535 DIMENSION IV(*)
18536
18537C input/output channels
18538 INTEGER LI,LO
18539 COMMON /POINOU/ LI,LO
18540C event debugging information
18541 INTEGER NMAXD
18542 PARAMETER (NMAXD=100)
18543 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18544 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18545 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18546 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18547C model switches and parameters
18548 CHARACTER*8 MDLNA
18549 INTEGER ISWMDL,IPAMDL
18550 DOUBLE PRECISION PARMDL
18551 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18552C data of c.m. system of Pomeron / Reggeon exchange
18553 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18554 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18555 & SIDP,CODP,SIFP,COFP
18556 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18557 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18558 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18559C data on most recent hard scattering
18560 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18561 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18562 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18563 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18564 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18565 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18566 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18567 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18568 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18569C data needed for soft-pt calculation
18570 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18571 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18572
18573 DIMENSION BETAB(100)
18574
18575C selection of pt
18576 IF(ISOFT.GE.0) THEN
18577 CALLS = CALLS + 1.D0
18578C sample according to model ISWMDL(3-6)
18579 IF(ISOFT.GT.1) THEN
18580 210 CONTINUE
18581 PTXS = 0.D0
18582 PTYS = 0.D0
18583 DO 300 I=2,ISOFT
18584 IMODE = ISWMDL(3)
18585C valence partons
18586 IF(IV(I).EQ.1) THEN
18587 BETA = BETAS(1)
18588C photon/pomeron valence part
18589 IF(IPAMDL(5).EQ.1) THEN
18590 IF(XV(I).GE.0.D0) THEN
18591 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18592 IMODE = ISWMDL(4)
18593 BETA = BETAS(3)
18594 ENDIF
18595 ELSE
18596 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18597 IMODE = ISWMDL(4)
18598 BETA = BETAS(3)
18599 ENDIF
18600 ENDIF
18601 ELSE IF(IPAMDL(5).EQ.2) THEN
18602 BETA = PARMDL(20)
18603 ELSE IF(IPAMDL(5).EQ.3) THEN
18604 BETA = BETAS(3)
18605 ENDIF
18606C sea partons
18607 ELSE IF(IV(I).EQ.0) THEN
18608 BETA = BETAS(3)
18609C hard scattering remnant
18610 ELSE
18611 IF(IPAMDL(6).EQ.0) THEN
18612 BETA = BETAS(1)
18613 ELSE IF(IPAMDL(6).EQ.1) THEN
18614 BETA = BETAS(3)
18615 ELSE
18616 BETA = PARMDL(20)
18617 ENDIF
18618 ENDIF
18619 BETA = MAX(BETA,0.01D0)
18620 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18621 PTS = MIN(PTMAX,PTS)
18622 CALL PHO_SFECFE(SIG,COG)
18623 PTSOF(0,I) = PTS
18624 PTSOF(1,I) = COG*PTS
18625 PTSOF(2,I) = SIG*PTS
18626 PTXS = PTXS+PTSOF(1,I)
18627 PTYS = PTYS+PTSOF(2,I)
18628 BETAB(I) = BETA
18629 300 CONTINUE
18630C balancing of momenta
18631 PTS = SQRT(PTXS**2+PTYS**2)
18632 IF(PTS.GE.PTMAX) GOTO 210
18633 PTSOF(0,1) = PTS
18634 PTSOF(1,1) = -PTXS
18635 PTSOF(2,1) = -PTYS
18636 BETAB(1) = 0.D0
18637C
18638*400 CONTINUE
18639C
18640C single parton only
18641 ELSE
18642 IMODE = ISWMDL(3)
18643C valence partons
18644 IF(IV(1).EQ.1) THEN
18645 BETA = BETAS(1)
18646C photon/Pomeron valence part
18647 IF(IPAMDL(5).EQ.1) THEN
18648 IF(XV(1).GE.0.D0) THEN
18649 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18650 IMODE = ISWMDL(4)
18651 BETA = BETAS(3)
18652 ENDIF
18653 ELSE
18654 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18655 IMODE = ISWMDL(4)
18656 BETA = BETAS(3)
18657 ENDIF
18658 ENDIF
18659 ELSE IF(IPAMDL(5).EQ.2) THEN
18660 BETA = PARMDL(20)
18661 ELSE IF(IPAMDL(5).EQ.3) THEN
18662 BETA = BETAS(3)
18663 ENDIF
18664C sea partons
18665 ELSE IF(IV(1).EQ.0) THEN
18666 BETA = BETAS(3)
18667C hard scattering remnant
18668 ELSE
18669 IF(IPAMDL(6).EQ.1) THEN
18670 BETA = BETAS(3)
18671 ELSE
18672 BETA = PARMDL(20)
18673 ENDIF
18674 ENDIF
18675 BETA = MAX(BETA,0.01D0)
18676 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18677 PTS = MIN(PTMAX,PTS)
18678 CALL PHO_SFECFE(SIG,COG)
18679 PTSOF(0,1) = PTS
18680 PTSOF(1,1) = COG*PTS
18681 PTSOF(2,1) = SIG*PTS
18682 BETAB(1) = BETA
18683 ENDIF
18684C debug output
18685 IF(IDEB(29).GE.10) THEN
18686 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18687 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18688 DO 105 I=1,ISOFT
18689 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18690 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18691 105 CONTINUE
18692 ENDIF
18693
18694C initialization of statistics and parameters
18695
18696 ELSE IF(ISOFT.EQ.-1) THEN
18697 PTSMIN = 0.D0
18698 PTSMAX = PTCUT
18699 IMODE = -100+ISWMDL(3)
18700 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18701
18702C output of statistics
18703
18704 ELSE IF(ISOFT.EQ.-2) THEN
18705 ELSE
18706 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18707 & 'unsupported ISOFT ',ISOFT
18708 STOP
18709 ENDIF
18710 END
18711
18712*$ CREATE PHO_SELPT.FOR
18713*COPY PHO_SELPT
18714CDECK ID>, PHO_SELPT
18715 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18716C***********************************************************************
18717C
18718C select pt from different distributions
18719C
18720C input: EE energy (for initialization only)
18721C otherwise x value of corresponding parton
18722C PTLOW lower pt limit
18723C PTHIGH upper pt limit
18724C (PTHIGH > 20 will cause DEXP underflows)
18725C
18726C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18727C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18728C IMODE = 2 dNs/dP_t according photon wave function
18729C IMODE = 10 no sampling
18730C
18731C IMODE = -100+IMODE initialization according to
18732C given limitations
18733C
18734C output: PTS sampled pt value
18735C initialization:
18736C BETA soft pt slope in central region
18737C
18738C***********************************************************************
18739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18740 SAVE
18741
18742 PARAMETER ( PI2 = 6.28318530718D0,
18743 & AMIN = 1.D-2,
18744 & EPS = 1.D-7,
18745 & DEPS = 1.D-30)
18746
18747C input/output channels
18748 INTEGER LI,LO
18749 COMMON /POINOU/ LI,LO
18750C event debugging information
18751 INTEGER NMAXD
18752 PARAMETER (NMAXD=100)
18753 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18754 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18755 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18756 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18757C model switches and parameters
18758 CHARACTER*8 MDLNA
18759 INTEGER ISWMDL,IPAMDL
18760 DOUBLE PRECISION PARMDL
18761 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18762C data of c.m. system of Pomeron / Reggeon exchange
18763 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18764 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18765 & SIDP,CODP,SIFP,COFP
18766 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18767 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18768 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18769C average number of cut soft and hard ladders (obsolete)
18770 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18771 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18772C data needed for soft-pt calculation
18773 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18774 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18775
18776 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18777 EXTERNAL PHO_CONN0,PHO_CONN1
18778
18779C initialization
18780
18781 IF(IMODE.LT.0) GOTO 100
18782
18783 PX = PTHIGH
18784 PTS = 0.D0
18785
18786C initial checks
18787
18788 IF(PX.LT.AMIN) RETURN
18789
18790 IF((PX-PTLOW).LT.0.01) THEN
18791 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18792 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18793 RETURN
18794 ENDIF
18795
18796C sampling of pt values according to IMODE
18797
18798 IF(IMODE.EQ.0) THEN
18799
18800 FAC1 = EXP(-BETA*PX**2)
18801 FAC2 = (1.D0-FAC1)
18802 25 CONTINUE
18803 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18804 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18805 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18806
18807 ELSE IF(IMODE.EQ.1) THEN
18808
18809 XIMIN = EXP(-BETA*PTHIGH)
18810 XIDEL = 1.D0-XIMIN
18811 50 CONTINUE
18812 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18813 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18814 IF(PTS.LT.XMT) GOTO 50
18815 PTS = SQRT(PTS**2-XMT2)
18816 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18817
18818 ELSE IF(IMODE.EQ.2) THEN
18819
18820 IF(EE.GE.0.D0) THEN
18821 P2 = PVIRTP(1)
18822 ELSE
18823 P2 = PVIRTP(2)
18824 ENDIF
18825 XV = ABS(EE)
18826 AA = (1.D0-XV)*XV*P2+PARMDL(25)
18827 75 CONTINUE
18828 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18829 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18830
18831C something wrong
18832
18833 ELSE IF(IMODE.NE.10) THEN
18834 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18835 CALL PHO_ABORT
18836 ENDIF
18837
18838C debug output
18839 IF(IDEB(5).GE.20) THEN
18840 WRITE(LO,'(1X,A,I3,4E10.3)')
18841 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18842 & IMODE,BETA,PTLOW,PTHIGH,PTS
18843 ENDIF
18844 RETURN
18845
18846C initialization
18847 100 CONTINUE
18848 PTSMIN = PTLOW
18849 PTSMAX = PTHIGH
18850 PTCON = PTHIGH
18851C calculation of parameters
18852 INIT = IMODE+100
18853 AAS = 0.D0
18854
18855C initialization for model 0 (gaussian pt distribution)
18856
18857 IF(INIT.EQ.0) THEN
18858 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18859 BETUP = BETAS(1)
18860 BETLO = -2.D0
18861 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18862 IF(XTOL.LT.0.D0) THEN
18863 XTOL = 1.D-4
18864 METHOD = 1
18865 MAXF = 500
18866 BETA = 0.D0
18867 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18868* IF(BETA.LT.-1.D+10) THEN
18869* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18870* & '(model 0: Ecm,PTcut)',EE,PTCON
18871* WRITE(LO,'(1X,A,1P,3E10.3)')
18872* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18873* CALL PHO_PREVNT(-1)
18874* BETA = 0.01
18875* ELSE
18876 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18877* ENDIF
18878 ELSE
18879 AAS = 0.D0
18880 BETA = BETAS(1)
18881 ENDIF
18882
18883C initialization for model 1 (exponential pt distribution)
18884
18885 ELSE IF(INIT.EQ.1) THEN
18886 XMT = PARMDL(43)
18887 XMT2 = XMT*XMT
18888 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18889 BETUP = BETAS(1)
18890 BETLO = -3.D0
18891 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18892 IF(XTOL.LT.0.D0) THEN
18893 XTOL = 1.D-4
18894 METHOD = 1
18895 MAXF = 500
18896 BETA = 0.D0
18897 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18898* IF(BETA.LT.-1.D+10) THEN
18899* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18900* & '(model 1: Ecm,PTcut)',EE,PTCON
18901* WRITE(LO,'(1X,A,1P,3E10.3)')
18902* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18903* CALL PHO_PREVNT(-1)
18904* BETA = 0.01
18905* ELSE
18906 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18907* ENDIF
18908 ELSE
18909 AAS = 0.D0
18910 BETA = BETAS(1)
18911 ENDIF
18912 ELSE IF(INIT.EQ.10) THEN
18913 IF(IDEB(5).GT.10)
18914 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18915 RETURN
18916 ELSE
18917 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18918 & INIT
18919 CALL PHO_ABORT
18920 ENDIF
18921 BETA = MIN(BETA,BETAS(1))
18922
18923C hard cross section is too big: neg. beta parameter
18924 IF(BETA.LE.0.D0) THEN
18925 WRITE(LO,'(1X,A,1P,2E12.3)')
18926 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18927 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18928 & SIGS,DSIGHP,SIGH,PTCON
18929 CALL PHO_PREVNT(-1)
18930 ENDIF
18931
18932C output of initialization parameters
18933 IF(IDEB(5).GE.10) THEN
18934 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18935 & INIT
18936 WRITE(LO,'(5X,A,1P,2E13.3)')
18937 & 'BETA,AAS ',BETA,AAS
18938 WRITE(LO,'(5X,A,1P,3E13.3)')
18939 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18940 WRITE(LO,'(5X,A,1P,3E13.3)')
18941 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18942 ENDIF
18943
18944 END
18945
18946*$ CREATE PHO_CONN0.FOR
18947*COPY PHO_CONN0
18948CDECK ID>, PHO_CONN0
18949 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18950C***********************************************************************
18951C
18952C auxiliary function to determine parameters of soft
18953C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18954C
18955C internal factors: FS number of soft partons in soft Pomeron
18956C FH number of soft partons in hard Pomeron
18957C
18958C***********************************************************************
18959 IMPLICIT NONE
18960 SAVE
18961
18962C input/output channels
18963 INTEGER LI,LO
18964 COMMON /POINOU/ LI,LO
18965C average number of cut soft and hard ladders (obsolete)
18966 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18967 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18968C data needed for soft-pt calculation
18969 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18970 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18971
18972 DOUBLE PRECISION BETA,XX,FF
18973
18974 XX = BETA*PTCON**2
18975 IF(ABS(XX).LT.1.D-3) THEN
18976 FF = FS*SIGS+FH*SIGH
18977 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18978 ELSE
18979 FF = FS*SIGS+FH*SIGH
18980 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18981 ENDIF
18982 PHO_CONN0 = FF
18983
18984* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18985* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18986
18987 END
18988
18989*$ CREATE PHO_CONN1.FOR
18990*COPY PHO_CONN1
18991CDECK ID>, PHO_CONN1
18992 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18993C***********************************************************************
18994C
18995C auxiliary function to determine parameters of soft
18996C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18997C
18998C internal factors: FS number of soft partons in soft Pomeron
18999C FH number of soft partons in hard Pomeron
19000C
19001C***********************************************************************
19002 IMPLICIT NONE
19003 SAVE
19004
19005C input/output channels
19006 INTEGER LI,LO
19007 COMMON /POINOU/ LI,LO
19008C average number of cut soft and hard ladders (obsolete)
19009 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19010 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19011C data needed for soft-pt calculation
19012 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19013 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19014
19015 DOUBLE PRECISION BETA,XX,FF
19016
19017 XX = BETA*PTCON
19018 IF(ABS(XX).LT.1.D-3) THEN
19019 FF = FS*SIGS+FH*SIGH
19020 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19021 ELSE
19022 FF = FS*SIGS+FH*SIGH
19023 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19024 ENDIF
19025 PHO_CONN1 = FF
19026
19027* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19028* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19029
19030 END
19031
19032*$ CREATE PHO_MSHELL.FOR
19033*COPY PHO_MSHELL
19034CDECK ID>, PHO_MSHELL
19035 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19036C********************************************************************
19037C
19038C rescaling of momenta of two partons to put both
19039C on mass shell
19040C
19041C input: PA1,PA2 input momentum vectors
19042C XM1,2 desired masses of particles afterwards
19043C P1,P2 changed momentum vectors
19044C
19045C********************************************************************
19046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19047 SAVE
19048
19049 PARAMETER ( DEPS = 1.D-20 )
19050
19051 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19052
19053C input/output channels
19054 INTEGER LI,LO
19055 COMMON /POINOU/ LI,LO
19056C event debugging information
19057 INTEGER NMAXD
19058 PARAMETER (NMAXD=100)
19059 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19060 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19061 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19062 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19063C internal rejection counters
19064 INTEGER NMXJ
19065 PARAMETER (NMXJ=60)
19066 CHARACTER*10 REJTIT
19067 INTEGER IFAIL
19068 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19069
19070 IREJ = 0
19071 IDEV = 0
19072C debug output
19073 IF(IDEB(40).GE.10) THEN
19074 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19075 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19076 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19077 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19078 ENDIF
19079
19080C Lorentz transformation into system CMS
19081 PX = PA1(1)+PA2(1)
19082 PY = PA1(2)+PA2(2)
19083 PZ = PA1(3)+PA2(3)
19084 EE = PA1(4)+PA2(4)
19085 XMS = EE**2-PX**2-PY**2-PZ**2
19086 IF(XMS.LT.(XM1+XM2)**2) THEN
19087 IREJ = 1
19088 IFAIL(37) = IFAIL(37)+1
19089
19090 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19091
19092 IF(IDEB(40).GE.3) THEN
19093 WRITE(LO,'(/1X,A,I12)')
19094 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19095 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19096 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19097 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19098 IDEV = 5
19099 IF(IDEB(40).GE.3) GOTO 55
19100 ENDIF
19101 RETURN
19102 ENDIF
19103 XMS = SQRT(XMS)
19104 BGX = PX/XMS
19105 BGY = PY/XMS
19106 BGZ = PZ/XMS
19107 GAM = EE/XMS
19108 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19109 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19110C rotation angles
19111 PTOT1 = MAX(DEPS,PTOT1)
19112 COD = P1(3)/PTOT1
19113 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19114 COF = 1.D0
19115 SIF = 0.D0
19116 IF(PTOT1*SID.GT.1.D-5) THEN
19117 COF = P1(1)/(SID*PTOT1)
19118 SIF = P1(2)/(SID*PTOT1)
19119 ANORF = SQRT(COF*COF+SIF*SIF)
19120 COF = COF/ANORF
19121 SIF = SIF/ANORF
19122 ENDIF
19123
19124C new CM momentum and energies (for masses XM1,XM2)
19125 XM12 = XM1**2
19126 XM22 = XM2**2
19127 SS = XMS**2
19128 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19129 EE1 = SQRT(XM12+PCMP**2)
19130 EE2 = XMS-EE1
19131C back rotation
19132 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19133 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19134 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19135 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19136 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19137
19138C check consistency
19139 DEL = XMS*0.0001
19140 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19141 IDEV = 1
19142 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19143 IDEV = 2
19144 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19145 IDEV = 3
19146 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19147 IDEV = 4
19148 ENDIF
19149 55 CONTINUE
19150C debug output
19151 IF(IDEV.NE.0) THEN
19152 WRITE(LO,'(1X,A,I3)')
19153 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19154 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19155 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19156 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19157 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19158 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19159 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19160 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19161 ELSE IF(IDEB(40).GE.10) THEN
19162 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19163 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19164 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19165 ENDIF
19166 END
19167
19168*$ CREATE PHO_GLU2QU.FOR
19169*COPY PHO_GLU2QU
19170CDECK ID>, PHO_GLU2QU
19171 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19172C********************************************************************
19173C
19174C split gluon with index I in POEVT1
19175C (massless gluon assumed)
19176C
19177C input: /POEVT1/
19178C IG gluon index
19179C IQ1 first quark index
19180C IQ2 second quark index
19181C
19182C output: new quarks in /POEVT1/
19183C IREJ 1 splitting impossible
19184C 0 splitting successful
19185C
19186C********************************************************************
19187 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19188 SAVE
19189
19190 PARAMETER ( DEPS = 1.D-15,
19191 & EPS = 1.D-5 )
19192
19193C input/output channels
19194 INTEGER LI,LO
19195 COMMON /POINOU/ LI,LO
19196C event debugging information
19197 INTEGER NMAXD
19198 PARAMETER (NMAXD=100)
19199 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19200 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19201 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19202 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19203C model switches and parameters
19204 CHARACTER*8 MDLNA
19205 INTEGER ISWMDL,IPAMDL
19206 DOUBLE PRECISION PARMDL
19207 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19208C standard particle data interface
19209 INTEGER NMXHEP
19210 PARAMETER (NMXHEP=4000)
19211 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19212 DOUBLE PRECISION PHEP,VHEP
19213 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19214 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19215 & VHEP(4,NMXHEP)
19216C extension to standard particle data interface (PHOJET specific)
19217 INTEGER IMPART,IPHIST,ICOLOR
19218 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19219C internal rejection counters
19220 INTEGER NMXJ
19221 PARAMETER (NMXJ=60)
19222 CHARACTER*10 REJTIT
19223 INTEGER IFAIL
19224 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19225
19226 DIMENSION P1(4),P2(4)
19227 DATA CUTM /0.02D0/
19228
19229 IREJ = 0
19230
19231C calculate string masses max possible
19232 IF(ISWMDL(9).EQ.1) THEN
19233 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19234 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19235 IF(CMASS1.LT.CUTM) THEN
19236 IF(IDEB(73).GE.5) THEN
19237 WRITE(LO,'(1X,A,3I4,4E10.3)')
19238 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19239 ENDIF
19240 IFAIL(33) = IFAIL(33) + 1
19241 IREJ = 1
19242 RETURN
19243 ENDIF
19244 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19245 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19246 IF(CMASS2.LT.CUTM) THEN
19247 IF(IDEB(73).GE.5) THEN
19248 WRITE(LO,'(1X,A,3I4,4E10.3)')
19249 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19250 ENDIF
19251 IFAIL(33) = IFAIL(33) + 1
19252 IREJ = 1
19253 RETURN
19254 ENDIF
19255C
19256C calculate minimal z
19257 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19258 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19259 ZMIN = MIN(ZMIN1,ZMIN2)
19260 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19261 IF(IDEB(73).GE.5) THEN
19262 WRITE(LO,'(1X,A,3I3,4E10.3)')
19263 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19264 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19265 ENDIF
19266 IFAIL(33) = IFAIL(33) + 1
19267 IREJ = 1
19268 RETURN
19269 ENDIF
19270 ELSE
19271 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19272 ENDIF
19273C
19274 ZFRAC = PHO_GLUSPL(ZMIN)
19275 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19276 ZFRAC = 1.D0-ZFRAC
19277 ENDIF
19278 DO 200 I=1,4
19279 P1(I) = PHEP(I,IG)*ZFRAC
19280 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19281 200 CONTINUE
19282C quark flavours
19283 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19284 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19285 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19286 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19287 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19288 K = SIGN(ABS(K),IDHEP(IQ1))
19289 ELSE
19290 K = -SIGN(ABS(K),IDHEP(IQ1))
19291 ENDIF
19292C colors
19293 IF(K.GT.0) THEN
19294 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19295 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19296 ELSE
19297 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19298 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19299 ENDIF
19300C register new partons
19301 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19302 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19303 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19304 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19305C debug output
19306 IF(IDEB(73).GE.20) THEN
19307 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19308 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19309 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19310 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19311 & K,-K,IC1,IC2
19312 ENDIF
19313 END
19314
19315*$ CREATE PHO_GLUSPL.FOR
19316*COPY PHO_GLUSPL
19317CDECK ID>, PHO_GLUSPL
19318 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19319C*********************************************************************
19320C
19321C calculate quark - antiquark light cone momentum fractions
19322C according to Altarelli-Parisi g->q aq splitting function
19323C (symmetric z interval assumed)
19324C
19325C input: ZMIN minimal Z value allowed,
19326C 1-ZMIN maximal Z value allowed
19327C
19328C********************************************************************
19329 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19330 SAVE
19331
19332 PARAMETER ( ALEXP= 0.3333333333D0,
19333 & DEPS = 1.D-10 )
19334
19335C input/output channels
19336 INTEGER LI,LO
19337 COMMON /POINOU/ LI,LO
19338C event debugging information
19339 INTEGER NMAXD
19340 PARAMETER (NMAXD=100)
19341 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19342 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19343 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19344 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19345
19346 IF(ZMIN.GE.0.5D0) THEN
19347 IF(IDEB(69).GT.2) THEN
19348 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19349 ENDIF
19350 ZZ=0.D0
19351 GOTO 1000
19352 ELSE IF(ZMIN.LE.0.D0) THEN
19353 IF(IDEB(69).GT.2) THEN
19354 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19355 ENDIF
19356 ZMINL = DEPS
19357 ELSE
19358 ZMINL = ZMIN
19359 ENDIF
19360
19361 ZMAX = 1.D0-ZMINL
19362 XI = DT_RNDM(ZMAX)
19363 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19364 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19365
19366 1000 CONTINUE
19367 IF(IDEB(69).GE.10) THEN
19368 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19369 ENDIF
19370 PHO_GLUSPL = ZZ
19371 END
19372
19373*$ CREATE PHO_STDPAR.FOR
19374*COPY PHO_STDPAR
19375CDECK ID>, PHO_STDPAR
19376 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19377C***********************************************************************
19378C
19379C select the initial parton x-fractions and flavors and
19380C the final parton momenta and flavours
19381C for standard Pomeron/Reggeon cuts
19382C
19383C input: IJM1 index of mother particle 1 in /POEVT1/
19384C IJM2 index of mother particle 2 in /POEVT1/
19385C IGEN production process of mother particles
19386C MSPOM soft cut Pomerons
19387C MHPOM hard or semihard cut Pomerons
19388C MSREG soft cut Reggeons
19389C MHDIR direct hard processes
19390C
19391C IJM1 -1 initialization of statistics
19392C -2 output of statistics
19393C
19394C output: partons are directly written to /POEVT1/,/POEVT2/
19395C
19396C structure of /POSOFT/
19397C XS1(I),XS2(I): x-values of initial partons
19398C IJSI1(I),IJSI2(I): flavor of initial parton
19399C 0 gluon
19400C 1,2,3,4 quarks
19401C negative antiquarks
19402C IJSF1(I),IJSF2(I): flavor of final state partons
19403C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19404C J=1 PX
19405C =2 PY
19406C =3 PZ
19407C =4 ENERGY
19408C
19409C***********************************************************************
19410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19411 SAVE
19412
19413 PARAMETER (RHOMAS = 0.766D0,
19414 & DEPS = 1.D-10,
19415 & TINY = 1.D-10)
19416
19417C input/output channels
19418 INTEGER LI,LO
19419 COMMON /POINOU/ LI,LO
19420C event debugging information
19421 INTEGER NMAXD
19422 PARAMETER (NMAXD=100)
19423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19427C model switches and parameters
19428 CHARACTER*8 MDLNA
19429 INTEGER ISWMDL,IPAMDL
19430 DOUBLE PRECISION PARMDL
19431 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19432C some constants
19433 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19434 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19435 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19436C general process information
19437 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19438 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19439C global event kinematics and particle IDs
19440 INTEGER IFPAP,IFPAB
19441 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19442 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19443C data of c.m. system of Pomeron / Reggeon exchange
19444 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19445 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19446 & SIDP,CODP,SIFP,COFP
19447 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19448 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19449 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19450C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19451 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19452 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19453 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19454 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19455C obsolete cut-off information
19456 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19457 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19458C currently activated parton density parametrizations
19459 CHARACTER*8 PDFNAM
19460 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19461 DOUBLE PRECISION PDFLAM,PDFQ2M
19462 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19463 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19464C hard scattering parameters used for most recent hard interaction
19465 INTEGER NFbeta,NF
19466 DOUBLE PRECISION ALQCD2,BQCD
19467 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19468C particles created by initial state evolution
19469 INTEGER MXISR1,MXISR2
19470 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19471 INTEGER IFLISR,IPOISR,IMXISR
19472 DOUBLE PRECISION PHISR
19473 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19474 & IPOISR(2,2,MXISR2),IMXISR(2)
19475C light-cone x fractions and c.m. momenta of soft cut string ends
19476 INTEGER MAXSOF
19477 PARAMETER ( MAXSOF = 50 )
19478 INTEGER IJSI2,IJSI1
19479 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19480 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19481 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19482 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19483C table of particle indices for recursive PHOJET calls
19484 INTEGER MAXIPX
19485 PARAMETER ( MAXIPX = 100 )
19486 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19487 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19488 & IPOIX1,IPOIX2,IPOIX3
19489C hard scattering data
19490 INTEGER MSCAHD
19491 PARAMETER ( MSCAHD = 50 )
19492 INTEGER LSCAHD,LSC1HD,LSIDX,
19493 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19494 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19495 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19496 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19497 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19498 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19499 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19500 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19501 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19502C standard particle data interface
19503 INTEGER NMXHEP
19504 PARAMETER (NMXHEP=4000)
19505 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19506 DOUBLE PRECISION PHEP,VHEP
19507 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19508 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19509 & VHEP(4,NMXHEP)
19510C extension to standard particle data interface (PHOJET specific)
19511 INTEGER IMPART,IPHIST,ICOLOR
19512 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19513C internal rejection counters
19514 INTEGER NMXJ
19515 PARAMETER (NMXJ=60)
19516 CHARACTER*10 REJTIT
19517 INTEGER IFAIL
19518 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19519C internal cross check information on hard scattering limits
19520 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19521 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19522C hard cross sections and MC selection weights
19523 INTEGER Max_pro_2
19524 PARAMETER ( Max_pro_2 = 16 )
19525 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19526 & MH_acc_1,MH_acc_2
19527 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19528 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19529 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19530 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19531 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19532 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19533
19534 double precision pho_alphas
19535
19536 DIMENSION PC(4),IFLA(2),ICI(2,2)
19537
19538 IF(IJM1.EQ.-1) THEN
19539 DO 116 I=1,15
19540 ETAMI(1,I) = 1.D10
19541 ETAMA(1,I) = -1.D10
19542 ETAMI(2,I) = 1.D10
19543 ETAMA(2,I) = -1.D10
19544 XXMI(1,I) = 1.D0
19545 XXMA(1,I) = 0.D0
19546 XXMI(2,I) = 1.D0
19547 XXMA(2,I) = 0.D0
19548 116 CONTINUE
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
19554 ELSE IF(IJM1.EQ.-2) THEN
19555
19556C output internal statistics
19557 IF(IDEB(23).GE.1) THEN
19558 WRITE(LO,'(/1X,A)')
19559 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19560 DO 117 I=1,15
19561 WRITE(LO,'(5X,I3,4E13.5)')
19562 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19563 117 CONTINUE
19564 WRITE(LO,'(1X,A)')
19565 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19566 DO 118 I=1,15
19567 WRITE(LO,'(5X,I3,4E13.5)')
19568 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19569 118 CONTINUE
19570 ENDIF
19571 CALL PHO_HARSCA(IJM1,1)
19572 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19573
19574 RETURN
19575 ENDIF
19576
19577 IREJ = 0
19578C debug output
19579 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19580 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19581
19582C get mother data (exchange if first particle is a pomeron)
19583 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19584 JM1 = IJM2
19585 JM2 = IJM1
19586 ELSE
19587 JM1 = IJM1
19588 JM2 = IJM2
19589 ENDIF
19590
19591 NPOSP(1) = JM1
19592 NPOSP(2) = JM2
19593 IDPDG1 = IDHEP(JM1)
19594 IDBAM1 = IMPART(JM1)
19595 IDPDG2 = IDHEP(JM2)
19596 IDBAM2 = IMPART(JM2)
19597
19598C store current status of /POEVT1/
19599 KHPOMS = KHPOM
19600 KSPOMS = KSPOM
19601 KSREGS = KSREG
19602 KHDIRS = KHDIR
19603 NHEPS = NHEP
19604 IPOIS1 = IPOIX1
19605 IPOIS2 = IPOIX2
19606
19607C get nominal masses (photons: VDM assumption)
19608 DELMAS = 0.D0
19609 IF(IDHEP(JM1).EQ.22) THEN
19610 PMASSP(1) = RHOMAS+DELMAS
19611 PVIRTP(1) = PHEP(5,JM1)**2
19612 ELSE
19613 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19614 PVIRTP(1) = 0.D0
19615 ENDIF
19616 IF(IDHEP(JM2).EQ.22) THEN
19617 PMASSP(2) = RHOMAS+DELMAS
19618 PVIRTP(2) = PHEP(5,JM2)**2
19619 ELSE
19620 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19621 PVIRTP(2) = 0.D0
19622 ENDIF
19623
19624C calculate c.m. energy and check kinematics
19625 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19626 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19627 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19628 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19629 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19630
19631 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19632 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19633 & 'energy smaller than two-particle threshold (event rejected)'
19634 CALL PHO_PREVNT(1)
19635 IREJ = 5
19636 GOTO 150
19637 ENDIF
19638 ECMP = SQRT(SS)
19639
19640 IF(IDEB(23).GE.5) THEN
19641 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19642 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19643 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19644 ENDIF
19645
19646C Lorentz transformation into c.m. system
19647 DO 10 I=1,4
19648 GAMBEP(I) = PC(I)/ECMP
19649 10 CONTINUE
19650 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19651 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19652 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19653C rotation angle: particle 1 moves along +z
19654 CODP = PC(3)/PTOT1
19655 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19656 COFP = 1.D0
19657 SIFP = 0.D0
19658 IF(PTOT1*SIDP.GT.1.D-5) THEN
19659 COFP = PC(1)/(SIDP*PTOT1)
19660 SIFP = PC(2)/(SIDP*PTOT1)
19661 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19662 COFP = COFP/ANORF
19663 SIFP = SIFP/ANORF
19664 ENDIF
19665C get CM momentum
19666 XM12 = PMASSP(1)**2
19667 XM22 = PMASSP(2)**2
19668 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19669
19670C find particle combination
19671 II = 0
19672 IF(IDPDG2.EQ.IFPAP(2)) THEN
19673 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19674 ELSE IF(IDPDG2.EQ.990) THEN
19675 IF(IDPDG1.EQ.IFPAP(1)) THEN
19676 II = 2
19677 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19678 II = 3
19679 ELSE IF(IDPDG1.EQ.990) THEN
19680 II = 4
19681 ENDIF
19682 ENDIF
19683 IF(II.EQ.0) THEN
19684 IF(ISWMDL(14).GT.0) THEN
19685 II = 1
19686 ELSE
19687 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19688 & 'invalid particle combination:',IDPDG1,IDPDG2
19689 CALL PHO_ABORT
19690 ENDIF
19691 ENDIF
19692
19693C select parton distribution functions from tables
19694 IF((MHPOM+MHDIR).GT.0) THEN
19695 CALL PHO_ACTPDF(IDPDG1,1)
19696 CALL PHO_ACTPDF(IDPDG2,2)
19697C initialize alpha_s calculation
19698 DUMMY = PHO_ALPHAS(0.D0,-4)
19699 ENDIF
19700
19701C interpolate hard cross sections and rejection weights
19702 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19703 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19704
19705 NTRY = 10
19706
19707C position of first particle added to /POEVT2/
19708 NLOR1 = NHEP+1
19709
19710C ---------------- direct processes -----------------
19711
19712 IF(MHDIR.EQ.1) THEN
19713 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19714 IF(IREJ.EQ.50) RETURN
19715 IF(IREJ.NE.0) GOTO 150
19716C write comments to /POEVT1/
19717 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19718 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19719 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19720 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19721 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19722 & ICA1,ICA2,IPOS,1)
19723 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19724 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19725 & ICA1,ICA2,IPOS,1)
19726 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19727 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19728 & IPOS1,1)
19729 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19730 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19731 & IPOS2,1)
19732
19733C soft spectator partons
19734 ICA1 = 0
19735 ICA2 = 0
19736 ICB1 = 0
19737 ICB2 = 0
19738 IPDF1 = 0
19739 IPDF2 = 0
19740
19741C single resolved: QCD compton scattering
19742C ------------------------------
19743 IF(NPROHD(1).EQ.10) THEN
19744C register hadron remnant
19745 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19746 IPDF2 = 1000*IGRP(2)+ISET(2)
19747 ELSE IF(NPROHD(1).EQ.12) THEN
19748C register hadron remnant
19749 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19750 IPDF1 = 1000*IGRP(1)+ISET(1)
19751
19752C single resolved: photon gluon fusion
19753C ---------------------------
19754 ELSE IF(NPROHD(1).EQ.11) THEN
19755C register hadron remnant
19756 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19757 IPDF2 = 1000*IGRP(2)+ISET(2)
19758 ELSE IF(NPROHD(1).EQ.13) THEN
19759C register hadron remnant
19760 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19761 IPDF1 = 1000*IGRP(1)+ISET(1)
19762
19763C direct process (no remnant)
19764C ----------------------------
19765 ELSE IF(NPROHD(1).EQ.14) THEN
19766
19767 ENDIF
19768
19769C write final high-pt partons to POEVT1
19770 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19771 ICI(1,1) = ICA1
19772 ICI(1,2) = ICA2
19773 ICI(2,1) = ICB1
19774 ICI(2,2) = ICB2
19775 I = 1
19776 IFLA(1) = NINHD(I,1)
19777 IFLA(2) = NINHD(I,2)
19778C initial state radiation
19779 DO 130 K=1,2
19780 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19781 KK = 1
19782 137 CONTINUE
19783 IFLB = IFLISR(K,IPA)
19784 IF(ABS(IFLB).LE.6) THEN
19785C partons
19786 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19787 IF(IFLB.EQ.0) THEN
19788 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19789 & ICI(K,1),ICI(K,2),3)
19790 ELSE IF(IFLB.GT.0) THEN
19791 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19792 & ICI(K,1),ICI(K,2),4)
19793 ELSE
19794 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19795 & IC1,IC2,4)
19796 ENDIF
19797 ELSE
19798 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19799 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19800 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19801 KK = KK+1
19802 GOTO 137
19803 ENDIF
19804 ENDIF
19805 IF(IFLB.EQ.0) THEN
19806 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19807 & IC1,IC2,2)
19808 ELSE
19809 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19810 & ICI(K,1),ICI(K,2),2)
19811 ENDIF
19812 ENDIF
19813 IIFL = IPHO_CNV1(IFLB)
19814 IFLA(K) = IFLA(K)-IFLB
19815 IST = -1
19816 ELSE
19817C other particle
19818 IIFL = IFLB
19819 IC1 = 0
19820 IC2 = 0
19821 IST = 1
19822 ENDIF
19823 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19824 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19825 & IGEN,IC1,IC2,IPOS,1)
19826 135 CONTINUE
19827 130 CONTINUE
19828 ICOLOR(1,IPOS1-2) = ICI(1,1)
19829 ICOLOR(2,IPOS1-2) = ICI(1,2)
19830 ICOLOR(1,IPOS1-1) = ICI(2,1)
19831 ICOLOR(2,IPOS1-1) = ICI(2,2)
19832 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19833 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19834 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
19835 ICOLOR(1,IPOS1) = ICI(1,1)
19836 ICOLOR(2,IPOS1) = ICI(1,2)
19837 ICOLOR(1,IPOS2) = ICI(2,1)
19838 ICOLOR(2,IPOS2) = ICI(2,2)
19839 DO 140 K=1,2
19840 IPA = IPOISR(K,1,I)
19841 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19842 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19843 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19844 140 CONTINUE
19845 ELSE
19846 ICOLOR(1,IPOS1-2) = ICA1
19847 ICOLOR(2,IPOS1-2) = ICA2
19848 ICOLOR(1,IPOS1-1) = ICB1
19849 ICOLOR(2,IPOS1-1) = ICB2
19850 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19851 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19852 & NOUTHD(1,2),ICB1,ICB2)
19853 ICOLOR(1,IPOS1) = ICA1
19854 ICOLOR(2,IPOS1) = ICA2
19855 ICOLOR(1,IPOS2) = ICB1
19856 ICOLOR(2,IPOS2) = ICB2
19857 I = -1
19858 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19859 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19860 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19861 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19862 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19863 ENDIF
19864
19865C assign soft pt to spectators
19866 IF(ISWMDL(18).EQ.0) THEN
19867 IPOS2 = IPOS2-1
19868 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19869 IF(IREJ.NE.0) THEN
19870 IFAIL(26) = IFAIL(26) + 1
19871 GOTO 150
19872 ENDIF
19873
19874 ENDIF
19875
19876C ----------------- resolved processes -------------------
19877
19878C single Reggeon exchange
19879C ----------------------------
19880 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19881C flavours
19882 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19883 IF(IREJ.NE.0) THEN
19884 IFAIL(24) = IFAIL(24)+1
19885 GOTO 150
19886 ENDIF
19887C colors
19888 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19889 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19890 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19891 CALL PHO_SWAPI(ICA1,ICB1)
19892 ENDIF
19893 ECMH = ECMP/2.D0
19894
19895C registration
19896
19897C DPMJET call with special projectile / target
19898 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19899 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19900 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19901 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19902 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19903C default treatment
19904 ELSE
19905 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19906 & -1,IGEN,ICA1,0,IPOS1,1)
19907 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19908 & -1,IGEN,ICB1,0,IPOS2,1)
19909 ENDIF
19910
19911C soft pt assignment
19912 IF(ISWMDL(18).EQ.0) THEN
19913 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19914 IF(IREJ.NE.0) THEN
19915 IFAIL(25) = IFAIL(25) + 1
19916 GOTO 150
19917 ENDIF
19918 ENDIF
19919C
19920C multi Reggeon / Pomeron exchange
19921C----------------------------------------
19922 ELSE
19923C parton configuration
19924
19925 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19926 & MHPAR1,MHPAR2,IREJ)
19927
19928 IF(IREJ.EQ.50) RETURN
19929 IF(IREJ.NE.0) GOTO 150
19930
19931C register particles
19932 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19933 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19934 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19935
19936C register soft partons
19937 IF(IVAL1.NE.0) THEN
19938 IF(IVAL1.LT.0) THEN
19939 IND1 = 3
19940 IVAL1=-IVAL1
19941 ELSE
19942 IND1 = 2
19943 ENDIF
19944 ELSE IF(MSPOM.EQ.0) THEN
19945 IND1 = 4
19946 ELSE
19947 IND1 = 1
19948 ENDIF
19949 IF(IVAL2.NE.0) THEN
19950 IF(IVAL2.LT.0) THEN
19951 IND2 = 3
19952 IVAL2=-IVAL2
19953 ELSE
19954 IND2 = 2
19955 ENDIF
19956 ELSE IF(MSPOM.EQ.0) THEN
19957 IND2 = 4
19958 ELSE
19959 IND2 = 1
19960 ENDIF
19961
19962 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19963 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19964
19965C soft Pomeron final states
19966C -----------------------------------
19967 K = MSPOM+MHPOM+MSREG
19968 DO 50 I=1,MSPOM
19969
19970 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19971 IF(IREJ.NE.0) THEN
19972 IFAIL(8) = IFAIL(8) + 1
19973 GOTO 150
19974 ENDIF
19975C
19976 50 CONTINUE
19977
19978C soft Reggeon final states
19979C -----------------------------------------
19980 DO 75 I=1,MSREG
19981C flavours
19982 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19983 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19984 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19985 ELSE
19986 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19987 ENDIF
19988C colors
19989 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19990 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19991 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19992 & CALL PHO_SWAPI(ICA1,ICB1)
19993C registration
19994 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19995 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19996 & I,IGEN,ICA1,ICA2,IPOS1,1)
19997 IND1 = IND1+1
19998 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19999 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20000 & I,IGEN,ICB1,ICB2,IPOS2,1)
20001 IND2 = IND2+1
20002
20003 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20004 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20005 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20006
20007C soft pt assignment
20008 IF(ISWMDL(18).EQ.0) THEN
20009 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20010 IF(IREJ.NE.0) THEN
20011 IFAIL(25) = IFAIL(25) + 1
20012 GOTO 150
20013 ENDIF
20014 ENDIF
20015
20016 75 CONTINUE
20017
20018C hard Pomeron final states
20019C ------------------------------------
20020 IND1 = MSPAR1
20021 IND2 = MSPAR2
20022
20023 DO 100 L=1,MHPOM
20024 I = LSIDX(L)
20025
20026 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20027 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20028 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20029 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20030C write comments to /POEVT1/
20031 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20032 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20033 & IFLO1,IFLO2,IPOS,1)
20034 I1 = 8*I-7
20035 IPDF = 1000*IGRP(1)+ISET(1)
20036 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20037 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20038 & ICA1,ICA2,IPOS,1)
20039 IPDF = 1000*IGRP(2)+ISET(2)
20040 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20041 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20042 & ICB1,ICB2,IPOS,1)
20043 I1 = 8*I-3
20044 IPDF = 1000*IGRP(1)+ISET(1)
20045 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20046 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20047 & ICA1,ICA2,IPOS1,1)
20048 IPDF = 1000*IGRP(2)+ISET(2)
20049 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20050 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20051 & ICB1,ICB2,IPOS2,1)
20052
20053C spectator partons belonging to hard interaction
20054 IF(IVAL1.EQ.I) THEN
20055 IVQ = 1
20056 IND = 1
20057 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20058 IVQ = 0
20059 IND = 1
20060 ELSE
20061 IVQ = -1
20062 IND = IND1
20063 ENDIF
20064 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20065 IF(IVQ.LT.0) IND1 = IND1-IUSED
20066 IF(IVAL2.EQ.I) THEN
20067 IVQ = 1
20068 IND = 1
20069 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20070 IVQ = 0
20071 IND = 1
20072 ELSE
20073 IVQ = -1
20074 IND = IND2
20075 ENDIF
20076 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20077 IF(IVQ.LT.0) IND2 = IND2-IUSED
20078C
20079C register hard scattered partons
20080 IF((ISWMDL(8).GE.2)
20081 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20082 ICI(1,1) = ICA1
20083 ICI(1,2) = ICA2
20084 ICI(2,1) = ICB1
20085 ICI(2,2) = ICB2
20086 IFLA(1) = NINHD(I,1)
20087 IFLA(2) = NINHD(I,2)
20088C initial state radiation
20089 DO 230 K=1,2
20090 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20091 KK = 1
20092 237 CONTINUE
20093 IFLB = IFLISR(K,IPA)
20094 IF(ABS(IFLB).LE.6) THEN
20095C partons
20096 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20097 IF(IFLB.EQ.0) THEN
20098 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20099 & ICI(K,1),ICI(K,2),3)
20100 ELSE IF(IFLB.GT.0) THEN
20101 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20102 & ICI(K,1),ICI(K,2),4)
20103 ELSE
20104 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20105 & ICI(K,2),IC1,IC2,4)
20106 ENDIF
20107 ELSE
20108 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20109 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20110 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20111 KK = KK+1
20112 GOTO 237
20113 ENDIF
20114 ENDIF
20115 IF(IFLB.EQ.0) THEN
20116 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20117 & ICI(K,2),IC1,IC2,2)
20118 ELSE
20119 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20120 & ICI(K,1),ICI(K,2),2)
20121 ENDIF
20122 ENDIF
20123 IIFL = IPHO_CNV1(IFLB)
20124 IFLA(K) = IFLA(K)-IFLB
20125 IST = -1
20126 ELSE
20127C other particles
20128 IIFL = IFLB
20129 IC1 = 0
20130 IC2 = 0
20131 IST = 1
20132 ENDIF
20133 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20134 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20135 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20136 235 CONTINUE
20137 230 CONTINUE
20138 ICOLOR(1,IPOS1-2) = ICI(1,1)
20139 ICOLOR(2,IPOS1-2) = ICI(1,2)
20140 ICOLOR(1,IPOS1-1) = ICI(2,1)
20141 ICOLOR(2,IPOS1-1) = ICI(2,2)
20142 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20143 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20144 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20145 ICOLOR(1,IPOS1) = ICI(1,1)
20146 ICOLOR(2,IPOS1) = ICI(1,2)
20147 ICOLOR(1,IPOS2) = ICI(2,1)
20148 ICOLOR(2,IPOS2) = ICI(2,2)
20149 DO 240 K=1,2
20150 IPA = IPOISR(K,1,I)
20151 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20152 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20153 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20154 240 CONTINUE
20155 ELSE
20156 ICOLOR(1,IPOS1-2) = ICA1
20157 ICOLOR(2,IPOS1-2) = ICA2
20158 ICOLOR(1,IPOS1-1) = ICB1
20159 ICOLOR(2,IPOS1-1) = ICB2
20160 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20161 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20162 & NOUTHD(I,2),ICB1,ICB2)
20163 ICOLOR(1,IPOS1) = ICA1
20164 ICOLOR(2,IPOS1) = ICA2
20165 ICOLOR(1,IPOS2) = ICB1
20166 ICOLOR(2,IPOS2) = ICB2
20167 I1 = 8*I-3
20168 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20169 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20170 & ICA1,ICA2,IPOS,1)
20171 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20172 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20173 & ICB1,ICB2,IPOS,1)
20174 ENDIF
20175 100 CONTINUE
20176C end of resolved parton registration
20177 ENDIF
20178
20179 IF(MHDIR+MHPOM.GT.0) THEN
20180
20181 IF(ISWMDL(29).GE.1) THEN
20182C primordial kt of hard scattering
20183 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20184 IF(IREJ.NE.0) THEN
20185 IFAIL(27) = IFAIL(27)+1
20186 GOTO 150
20187 ENDIF
20188 ELSE IF(ISWMDL(24).GE.0) THEN
20189C give "soft" pt only to soft (spectator) partons in hard processes
20190 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20191 IF(IREJ.NE.0) THEN
20192 IFAIL(26) = IFAIL(26)+1
20193 GOTO 150
20194 ENDIF
20195 ENDIF
20196
20197 ENDIF
20198
20199C give "soft" pt to partons in soft Pomerons
20200 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20201 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20202 IF(IREJ.NE.0) THEN
20203 IFAIL(25) = IFAIL(25) + 1
20204 GOTO 150
20205 ENDIF
20206 ENDIF
20207
20208C boost back to lab frame
20209 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20210 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20211 RETURN
20212
20213C rejection treatment
20214 150 CONTINUE
20215 IFAIL(2) = IFAIL(2)+1
20216C reset counters
20217 KSPOM = KSPOMS
20218 KHPOM = KHPOMS
20219 KHDIR = KHDIRS
20220 KSREG = KSREGS
20221C reset mother-daugther relations
20222 JDAHEP(1,JM1) = 0
20223 JDAHEP(2,JM1) = 0
20224 JDAHEP(1,JM2) = 0
20225 JDAHEP(2,JM2) = 0
20226 ISTHEP(JM1) = 1
20227 ISTHEP(JM2) = 1
20228 IPOIX1 = IPOIS1
20229 IPOIX2 = IPOIS2
20230 NHEP = NHEPS
20231C debug
20232 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20233 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20234 & MSPOM,MHPOM,MSREG,MHDIR
20235 RETURN
20236
20237 END
20238
20239*$ CREATE PHO_HARCOL.FOR
20240*COPY PHO_HARCOL
20241CDECK ID>, PHO_HARCOL
20242 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20243 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20244C*********************************************************************
20245C
20246C calculate color flow for hard resolved process
20247C
20248C input: IP1..4 flavour of partons (PDG convention)
20249C V parton subprocess Mandelstam variable V = t/s
20250C (lightcone momenta assumed)
20251C ICA,ICB color labels
20252C MSPR process number
20253C -1 initialization of statistics
20254C -2 output of statistics
20255C
20256C output: ICC,ICD color label of final partons
20257C
20258C (it is possible to use the same variables for in and output)
20259C
20260C**********************************************************************
20261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20262 SAVE
20263
20264C input/output channels
20265 INTEGER LI,LO
20266 COMMON /POINOU/ LI,LO
20267C event debugging information
20268 INTEGER NMAXD
20269 PARAMETER (NMAXD=100)
20270 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20271 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20272 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20273 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20274C model switches and parameters
20275 CHARACTER*8 MDLNA
20276 INTEGER ISWMDL,IPAMDL
20277 DOUBLE PRECISION PARMDL
20278 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20279C names of hard scattering processes
20280 INTEGER Max_pro_1
20281 PARAMETER ( Max_pro_1 = 16 )
20282 CHARACTER*18 PROC
20283 COMMON /POHPRO/ PROC(0:Max_pro_1)
20284
20285 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20286
20287C initialization
20288 IF(MSPR.EQ.-1) THEN
20289 DO 200 I=1,8
20290 DO 210 K=1,5
20291 ICONF(I,K) = 0
20292 210 CONTINUE
20293 IRECN(I,1) = 0
20294 IRECN(I,2) = 0
20295 200 CONTINUE
20296 RETURN
20297C output of statistics
20298 ELSE IF(MSPR.EQ.-2) THEN
20299 IF(IDEB(26).LT.1) RETURN
20300 WRITE(LO,'(/1X,A,/1X,A)')
20301 & 'PHO_HARCOL: sampled color configurations',
20302 & '----------------------------------------'
20303 WRITE(LO,'(6X,A,15X,A)')
20304 & 'diagram color configurations (1-4)','sum'
20305 DO 300 I=1,8
20306 DO 310 K=1,4
20307 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20308 310 CONTINUE
20309 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20310 300 CONTINUE
20311 IF(ISWMDL(11).GE.2) THEN
20312 WRITE(LO,'(/6X,A)')
20313 & 'diagram with / without color re-connection'
20314 DO 320 I=1,8
20315 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20316 320 CONTINUE
20317 ENDIF
20318 RETURN
20319 ENDIF
20320C
20321C gluons: first color positive, quarks second color zero
20322 IF(IP1.EQ.0) THEN
20323 IF(ICA1.LT.0) THEN
20324 I = ICA2
20325 ICA2 = ICA1
20326 ICA1 = I
20327 ENDIF
20328 ELSE
20329 ICA2 = 0
20330 ENDIF
20331 IF(IP2.EQ.0) THEN
20332 IF(ICB1.LT.0) THEN
20333 I = ICB2
20334 ICB2 = ICB1
20335 ICB1 = I
20336 ENDIF
20337 ELSE
20338 ICB2 = 0
20339 ENDIF
20340 IC2 = 0
20341 IC4 = 0
20342C debug output
20343 IF(IDEB(26).GE.15)
20344 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20345 & 'PHO_HARCOL: process',MSPR,
20346 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20347C
20348 IRC = 0
20349 IF(IPAMDL(21).EQ.1) THEN
20350C
20351C soft color re-connection option
20352C
20353 IF(MSPR.EQ.1) THEN
20354C hard g g final state, only g g --> g g
20355 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20356 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20357 IC1 = ICA1
20358 IC2 = ICA2
20359 IC3 = ICB1
20360 IC4 = ICB2
20361 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20362 IRC = 1
20363 GOTO 100
20364 ENDIF
20365 ENDIF
20366 ELSE IF(MSPR.EQ.3) THEN
20367C hard q g final state
20368 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20369 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20370 IC1 = ICA1
20371 IC2 = ICA2
20372 IC3 = ICB1
20373 IC4 = ICB2
20374 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20375 IRC = 1
20376 GOTO 100
20377 ENDIF
20378 ENDIF
20379 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20380C hard q q final state
20381 IF(ICA1.NE.-ICB1) THEN
20382 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20383 IC1 = ICA1
20384 IC2 = ICA2
20385 IC3 = ICB1
20386 IC4 = ICB2
20387 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20388 IRC = 1
20389 GOTO 100
20390 ENDIF
20391 ENDIF
20392 ENDIF
20393 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20394 ENDIF
20395C
20396 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20397C
20398C large Nc limit of all graphs
20399C
20400 IF(MSPR.EQ.1) THEN
20401C g g --> g g
20402 IF(DT_RNDM(V).GT.0.5D0) THEN
20403 IC1 = ICB1
20404 IC2 = ICA2
20405 IC3 = ICA1
20406 IC4 = ICB2
20407 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20408 ELSE
20409 IC1 = ICA1
20410 IC2 = ICB2
20411 IC3 = ICB1
20412 IC4 = ICA2
20413 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20414 ENDIF
20415 ELSE IF(MSPR.EQ.2) THEN
20416C q qb --> g g
20417 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20418 IF(ICA1.LT.0) THEN
20419 IC1 = I1
20420 IC2 = ICA1
20421 IC3 = ICB1
20422 IC4 = I2
20423 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20424 ELSE
20425 IC1 = ICA1
20426 IC2 = I2
20427 IC3 = I1
20428 IC4 = ICB1
20429 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20430 ENDIF
20431 ELSE IF(MSPR.EQ.3) THEN
20432C q g --> q g
20433 IF(DT_RNDM(V).LT.0.5D0) THEN
20434 IF(IP1+IP2.GT.0) THEN
20435 IC1 = ICB1
20436 IC2 = ICA2
20437 IC3 = ICA1
20438 IC4 = ICB2
20439 ELSE IF(IP1.LT.0) THEN
20440 IC1 = ICB2
20441 IC3 = ICB1
20442 IC4 = ICA1
20443 ELSE
20444 IC1 = ICA1
20445 IC2 = ICB1
20446 IC3 = ICA2
20447 ENDIF
20448 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20449 ELSE
20450 IF(IP1.GT.0) THEN
20451 CALL PHO_HARCOR(-ICA1,ICB2)
20452 IC1 = ICA1
20453 IC3 = ICB1
20454 IC4 = -ICA1
20455 ELSE IF(IP2.GT.0) THEN
20456 CALL PHO_HARCOR(-ICB1,ICA2)
20457 IC1 = ICA1
20458 IC2 = -ICB1
20459 IC3 = ICB1
20460 ELSE IF(IP1.LT.0) THEN
20461 CALL PHO_HARCOR(-ICA1,ICB1)
20462 IC1 = ICA1
20463 IC3 = -ICA1
20464 IC4 = ICB2
20465 ELSE IF(IP2.LT.0) THEN
20466 CALL PHO_HARCOR(-ICB1,ICA1)
20467 IC1 = -ICB1
20468 IC2 = ICA2
20469 IC3 = ICB1
20470 ENDIF
20471 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20472 ENDIF
20473 ELSE IF(MSPR.EQ.4) THEN
20474C g g --> q qb
20475 IC1 = ICA1
20476 IC3 = ICB2
20477 CALL PHO_HARCOR(-ICB1,ICA2)
20478 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20479 IF(IP3*IC1.LT.0) THEN
20480 I = IC1
20481 IC1 = IC3
20482 IC3 = I
20483 ENDIF
20484 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20485 ELSE IF(MSPR.EQ.5) THEN
20486C q qb --> q qb
20487 IF(DT_RNDM(V).LT.0.5D0) THEN
20488 IF(ICA1*IP3.LT.0) THEN
20489 IC1 = ICB1
20490 IC3 = ICA1
20491 ELSE
20492 IC1 = ICA1
20493 IC3 = ICB1
20494 ENDIF
20495 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20496 ELSE
20497 IF(ICA1*IP3.LT.0) THEN
20498 IC1 = -ICA1
20499 IC3 = ICA1
20500 ELSE
20501 IC1 = ICA1
20502 IC3 = -ICA1
20503 ENDIF
20504 CALL PHO_HARCOR(-ICA1,ICB1)
20505 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20506 ENDIF
20507 ELSE IF(MSPR.EQ.6) THEN
20508C q qb --> qp qbp
20509 IF(ICA1*IP3.LT.0) THEN
20510 IC1 = ICB1
20511 IC3 = ICA1
20512 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20513 ELSE
20514 IC1 = ICA1
20515 IC3 = ICB1
20516 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20517 ENDIF
20518 ELSE IF(MSPR.EQ.7) THEN
20519C q q --> q q
20520 IF(DT_RNDM(V).LT.0.5D0) THEN
20521 IC1 = ICA1
20522 IC3 = ICB1
20523 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20524 ELSE
20525 IC1 = ICB1
20526 IC3 = ICA1
20527 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20528 ENDIF
20529 ELSE IF(MSPR.EQ.8) THEN
20530C q qp --> q qp
20531 IF(IP1*IP2.GT.0) THEN
20532 IF(IP3.EQ.IP1) THEN
20533 IC1 = ICB1
20534 IC3 = ICA1
20535 ELSE
20536 IC1 = ICA1
20537 IC3 = ICB1
20538 ENDIF
20539 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20540 ELSE
20541 IF(ICA1*IP3.LT.0) THEN
20542 IC1 = -ICA1
20543 IC3 = ICA1
20544 ELSE
20545 IC1 = ICA1
20546 IC3 = -ICA1
20547 ENDIF
20548 CALL PHO_HARCOR(-ICA1,ICB1)
20549 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20550 ENDIF
20551 ELSE
20552C unknown process
20553 WRITE(LO,'(/1X,A,I3)')
20554 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20555 CALL PHO_ABORT
20556 ENDIF
20557C
20558 ELSE
20559C
20560C color flow according to QCD leading order matrix element
20561C
20562 U = -(1.D0+V)
20563 IF(MSPR.EQ.1) THEN
20564C g g --> g g
20565 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20566 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20567 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20568 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20569 PCS = 0.D0
20570 DO 110 I=1,3
20571 PCS = PCS+PC(I)
20572 IF(XI.LT.PCS) GOTO 120
20573 110 CONTINUE
20574 120 CONTINUE
20575 IF(I.EQ.1) THEN
20576 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20577 IF(DT_RNDM(V).GT.0.5D0) THEN
20578 IC1 = I1
20579 IC2 = ICA2
20580 IC3 = ICB1
20581 IC4 = I2
20582 CALL PHO_HARCOR(-ICB2,ICA1)
20583 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20584 ELSE
20585 IC1 = ICA1
20586 IC2 = I2
20587 IC3 = I1
20588 IC4 = ICB2
20589 CALL PHO_HARCOR(-ICB1,ICA2)
20590 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20591 ENDIF
20592 ELSE IF(I.EQ.2) THEN
20593 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20594 IF(DT_RNDM(U).GT.0.5D0) THEN
20595 IC1 = ICB1
20596 IC2 = I2
20597 IC3 = I1
20598 IC4 = ICA2
20599 CALL PHO_HARCOR(-ICB2,ICA1)
20600 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20601 ELSE
20602 IC1 = I1
20603 IC2 = ICB2
20604 IC3 = ICA1
20605 IC4 = I2
20606 CALL PHO_HARCOR(-ICB1,ICA2)
20607 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20608 ENDIF
20609 ELSE
20610 IF(DT_RNDM(V).GT.0.5D0) THEN
20611 IC1 = ICB1
20612 IC2 = ICA2
20613 IC3 = ICA1
20614 IC4 = ICB2
20615 ELSE
20616 IC1 = ICA1
20617 IC2 = ICB2
20618 IC3 = ICB1
20619 IC4 = ICA2
20620 ENDIF
20621 ENDIF
20622 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20623 ELSE IF(MSPR.EQ.2) THEN
20624C q qb --> g g
20625 PC(1) = U/V-2.D0*U**2
20626 PC(2) = V/U-2.D0*V**2
20627 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20628 XI = (PC(1)+PC(2))*DT_RNDM(U)
20629 IF(XI.LT.PC(1)) THEN
20630 IF(ICA1.GT.0) THEN
20631 IC1 = ICA1
20632 IC2 = I2
20633 IC3 = I1
20634 IC4 = ICB1
20635 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20636 ELSE
20637 IC1 = I1
20638 IC2 = ICA1
20639 IC3 = ICB1
20640 IC4 = I2
20641 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20642 ENDIF
20643 ELSE
20644 IF(ICA1.GT.0) THEN
20645 IC1 = I1
20646 IC2 = ICB1
20647 IC3 = ICA1
20648 IC4 = I2
20649 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20650 ELSE
20651 IC1 = ICB1
20652 IC2 = I2
20653 IC3 = I1
20654 IC4 = ICA1
20655 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20656 ENDIF
20657 ENDIF
20658 ELSE IF(MSPR.EQ.3) THEN
20659C q g --> q g
20660 PC(1) = 2.D0*(U/V)**2-U
20661 PC(2) = 2.D0/V**2-1.D0/U
20662 XI = (PC(1)+PC(2))*DT_RNDM(V)
20663 IF(XI.LT.PC(1)) THEN
20664 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20665 IF(IP1.GT.0) THEN
20666 IC1 = I1
20667 IC3 = ICB1
20668 IC4 = I2
20669 CALL PHO_HARCOR(-ICA1,ICB2)
20670 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20671 ELSE IF(IP1.LT.0) THEN
20672 IC1 = I2
20673 IC3 = I1
20674 IC4 = ICB2
20675 CALL PHO_HARCOR(-ICA1,ICB1)
20676 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20677 ELSE IF(IP2.GT.0) THEN
20678 IC1 = ICA1
20679 IC2 = I2
20680 IC3 = I1
20681 CALL PHO_HARCOR(-ICB1,ICA2)
20682 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20683 ELSE
20684 IC1 = I1
20685 IC2 = ICA2
20686 IC3 = I2
20687 CALL PHO_HARCOR(-ICB1,ICA1)
20688 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20689 ENDIF
20690 ELSE
20691 IF(IP1.GT.0) THEN
20692 IC1 = ICB1
20693 IC3 = ICA1
20694 IC4 = ICB2
20695 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20696 ELSE IF(IP1.LT.0) THEN
20697 IC1 = ICB2
20698 IC3 = ICB1
20699 IC4 = ICA1
20700 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20701 ELSE IF(IP2.GT.0) THEN
20702 IC1 = ICB1
20703 IC2 = ICA2
20704 IC3 = ICA1
20705 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20706 ELSE
20707 IC1 = ICA1
20708 IC2 = ICB1
20709 IC3 = ICA2
20710 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20711 ENDIF
20712 ENDIF
20713 ELSE IF(MSPR.EQ.4) THEN
20714C g g --> q qb
20715 PC(1) = U/V-2.D0*U**2
20716 PC(2) = V/U-2.D0*V**2
20717 XI = (PC(1)+PC(2))*DT_RNDM(U)
20718 IF(XI.LT.PC(1)) THEN
20719 IF(IP3.GT.0) THEN
20720 IC1 = ICA1
20721 IC3 = ICB2
20722 CALL PHO_HARCOR(-ICB1,ICA2)
20723 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20724 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20725 ELSE
20726 IC1 = ICA2
20727 IC3 = ICB1
20728 CALL PHO_HARCOR(-ICB2,ICA1)
20729 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20730 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20731 ENDIF
20732 ELSE
20733 IF(IP3.GT.0) THEN
20734 IC1 = ICB1
20735 IC3 = ICA2
20736 CALL PHO_HARCOR(-ICB2,ICA1)
20737 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20738 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20739 ELSE
20740 IC1 = ICB2
20741 IC3 = ICA1
20742 CALL PHO_HARCOR(-ICB1,ICA2)
20743 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20744 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20745 ENDIF
20746 ENDIF
20747 ELSE IF(MSPR.EQ.5) THEN
20748C q qb --> q qb
20749 PC(1) = (1.D0+U**2)/V**2
20750 PC(2) = (V**2+U**2)
20751 XI = (PC(1)+PC(2))*DT_RNDM(V)
20752 IF(XI.LT.PC(1)) THEN
20753 CALL PHO_HARCOR(-ICB1,ICA1)
20754 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20755 IF(IP3.GT.0) THEN
20756 IC1 = I1
20757 IC3 = I2
20758 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20759 ELSE
20760 IC1 = I2
20761 IC3 = I1
20762 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20763 ENDIF
20764 ELSE
20765 IF(IP3.GT.0) THEN
20766 IC1 = MAX(ICA1,ICB1)
20767 IC3 = MIN(ICA1,ICB1)
20768 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20769 ELSE
20770 IC1 = MIN(ICA1,ICB1)
20771 IC3 = MAX(ICA1,ICB1)
20772 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20773 ENDIF
20774 ENDIF
20775 ELSE IF(MSPR.EQ.6) THEN
20776C q qb --> qp qpb
20777 IF(IP3.GT.0) THEN
20778 IC1 = MAX(ICA1,ICB1)
20779 IC3 = MIN(ICA1,ICB1)
20780 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20781 ELSE
20782 IC1 = MIN(ICA1,ICB1)
20783 IC3 = MAX(ICA1,ICB1)
20784 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20785 ENDIF
20786 ELSE IF(MSPR.EQ.7) THEN
20787C q q --> q q
20788 PC(1) = (1.D0+U**2)/V**2
20789 PC(2) = (1.D0+V**2)/U**2
20790 XI = (PC(1)+PC(2))*DT_RNDM(U)
20791 IF(XI.LT.PC(1)) THEN
20792 IC1 = ICB1
20793 IC3 = ICA1
20794 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20795 ELSE
20796 IC1 = ICA1
20797 IC3 = ICB1
20798 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20799 ENDIF
20800 ELSE IF(MSPR.EQ.8) THEN
20801C q qp --> q qp
20802 IF(IP1*IP2.LT.0) THEN
20803 CALL PHO_HARCOR(-ICB1,ICA1)
20804 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20805 IF(IP1.GT.0) THEN
20806 IC1 = I1
20807 IC3 = I2
20808 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20809 ELSE
20810 IC1 = I2
20811 IC3 = I1
20812 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20813 ENDIF
20814 ELSE
20815 IC1 = ICB1
20816 IC3 = ICA1
20817 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20818 ENDIF
20819
20820 ELSE IF(MSPR.EQ.10) THEN
20821C gam q --> q g
20822 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20823 IF(IP3.EQ.0) THEN
20824 CALL PHO_SWAPI(IC1,IC3)
20825 CALL PHO_SWAPI(IC2,IC4)
20826 ENDIF
20827 ELSE IF(MSPR.EQ.11) THEN
20828C gam g --> q q
20829 IC1 = ICB1
20830 IC3 = ICB2
20831 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20832 ELSE IF(MSPR.EQ.12) THEN
20833C q gam --> q g
20834 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20835 IF(IP3.EQ.0) THEN
20836 CALL PHO_SWAPI(IC1,IC3)
20837 CALL PHO_SWAPI(IC2,IC4)
20838 ENDIF
20839 ELSE IF(MSPR.EQ.13) THEN
20840C g gam --> q q
20841 IC1 = ICA1
20842 IC3 = ICA2
20843 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20844 ELSE IF(MSPR.EQ.14) THEN
20845 IF(ABS(IP3).GT.12) THEN
20846 IC1 = 0
20847 IC3 = 0
20848 ELSE
20849 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20850 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20851 ENDIF
20852 ELSE
20853C unknown process
20854 WRITE(LO,'(/1X,A,I3)')
20855 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20856 CALL PHO_ABORT
20857 ENDIF
20858 ENDIF
20859C
20860 100 CONTINUE
20861C debug output
20862 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20863 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20864C color connection?
20865* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20866* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20867* & .OR.(IC2.EQ.0))) THEN
20868C color exchange?
20869* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20870* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20871* IF(IRC.NE.1) THEN
20872* WRITE(LO,'(1X,A,I10,I3)')
20873* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20874* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20875* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20876* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20877* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20878* ENDIF
20879* IRC = 0
20880* ENDIF
20881* ENDIF
20882* IF(IRC.EQ.1) THEN
20883* WRITE(LO,'(1X,A,I10,I3)')
20884* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20885* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20886* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20887* WRITE(LO,'(5X,A,3I5,2X,3I5)')
20888* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20889* ENDIF
20890C
20891 ICC1 = IC1
20892 ICC2 = IC2
20893 ICD1 = IC3
20894 ICD2 = IC4
20895
20896 END
20897
20898*$ CREATE PHO_HARCOR.FOR
20899*COPY PHO_HARCOR
20900CDECK ID>, PHO_HARCOR
20901 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20902C***********************************************************************
20903C
20904C substituite color in /POEVT2/
20905C
20906C input: ICOLD old color
20907C ICNEW new color
20908C
20909C***********************************************************************
20910 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20911 SAVE
20912
20913C input/output channels
20914 INTEGER LI,LO
20915 COMMON /POINOU/ LI,LO
20916C standard particle data interface
20917 INTEGER NMXHEP
20918 PARAMETER (NMXHEP=4000)
20919 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20920 DOUBLE PRECISION PHEP,VHEP
20921 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20922 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20923 & VHEP(4,NMXHEP)
20924C extension to standard particle data interface (PHOJET specific)
20925 INTEGER IMPART,IPHIST,ICOLOR
20926 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20927
20928 DO 100 I=NHEP,3,-1
20929 IF(ISTHEP(I).EQ.-1) THEN
20930 IF(ICOLOR(1,I).EQ.ICOLD) THEN
20931 ICOLOR(1,I) = ICNEW
20932 RETURN
20933 ELSE IF(IDHEP(I).EQ.21) THEN
20934 IF(ICOLOR(2,I).EQ.ICOLD) THEN
20935 ICOLOR(2,I) = ICNEW
20936 RETURN
20937 ENDIF
20938 ENDIF
20939* ELSE IF(ISTHEP(I).EQ.20) THEN
20940* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
ecf67adb 20941* WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
9aaba0d6 20942* ICOLOR(1,I) = -ICNEW
20943* RETURN
20944* ELSE IF(IDHEP(I).EQ.21) THEN
20945* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
ecf67adb 20946* WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
9aaba0d6 20947* ICOLOR(2,I) = -ICNEW
20948* RETURN
20949* ENDIF
20950* ENDIF
20951 ENDIF
20952 100 CONTINUE
20953 END
20954
20955*$ CREATE PHO_HARREM.FOR
20956*COPY PHO_HARREM
20957CDECK ID>, PHO_HARREM
20958 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20959 & IUSED,IREJ)
20960C***********************************************************************
20961C
20962C sample color structure for initial quark/gluon of hard scattering
20963C and write hadron remnant to /POEVT1/
20964C
20965C input: JM1,2 index of mother particle in POEVT1
20966C IGEN mother particle production process
20967C IHPOS hard pomeron number
20968C INDXH index of hard parton
20969C positive for labels 1
20970C negative for labels 2
20971C IVAL 1 hard valence parton
20972C 0 hard sea parton connected by color flow with
20973C valence quarks
20974C -1 hard sea parton independent off valence
20975C quarks
20976C INDXS index of soft partons needed
20977C
20978C output: IC1,IC2 color label of initial parton
20979C IUSED number of soft X values used
20980C IREJ rejection flag
20981C
20982C**********************************************************************
20983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20984 SAVE
20985
20986 PARAMETER ( TINY = 1.D-10 )
20987
20988C input/output channels
20989 INTEGER LI,LO
20990 COMMON /POINOU/ LI,LO
20991C event debugging information
20992 INTEGER NMAXD
20993 PARAMETER (NMAXD=100)
20994 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20995 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20996 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20997 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20998C model switches and parameters
20999 CHARACTER*8 MDLNA
21000 INTEGER ISWMDL,IPAMDL
21001 DOUBLE PRECISION PARMDL
21002 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21003C data of c.m. system of Pomeron / Reggeon exchange
21004 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21005 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21006 & SIDP,CODP,SIFP,COFP
21007 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21008 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21009 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21010C obsolete cut-off information
21011 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21012 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21013C light-cone x fractions and c.m. momenta of soft cut string ends
21014 INTEGER MAXSOF
21015 PARAMETER ( MAXSOF = 50 )
21016 INTEGER IJSI2,IJSI1
21017 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21018 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21019 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21020 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21021C hard scattering data
21022 INTEGER MSCAHD
21023 PARAMETER ( MSCAHD = 50 )
21024 INTEGER LSCAHD,LSC1HD,LSIDX,
21025 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21026 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21027 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21028 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21029 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21030 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21031 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21032 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21033 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21034C standard particle data interface
21035 INTEGER NMXHEP
21036 PARAMETER (NMXHEP=4000)
21037 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21038 DOUBLE PRECISION PHEP,VHEP
21039 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21040 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21041 & VHEP(4,NMXHEP)
21042C extension to standard particle data interface (PHOJET specific)
21043 INTEGER IMPART,IPHIST,ICOLOR
21044 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21045C internal rejection counters
21046 INTEGER NMXJ
21047 PARAMETER (NMXJ=60)
21048 CHARACTER*10 REJTIT
21049 INTEGER IFAIL
21050 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21051
21052 IREJ = 0
21053
21054 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21055
21056 IF(INDXH.GT.0) THEN
21057 IJH = IPHO_CNV1(NINHD(INDXH,1))
21058 ELSE
21059 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21060 ENDIF
21061C direct process (photon or pomeron)
21062 IUSED = 0
21063 IC1 = 0
21064 IC2 = 0
21065 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21066
21067 IHP = 100*ABS(IHPOS)
21068 IVSW = 1
21069***************************************
21070* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21071***************************************
21072
21073 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21074 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21075 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21076
21077C quark
21078C****************************************************************
21079
21080 IF(IJH.NE.21) THEN
21081
21082C valence quark engaged in hard scattering
21083 IF(IVAL.EQ.1) THEN
21084 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21085 IF(IREJ.NE.0) THEN
21086 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21087 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21088 return
21089 ENDIF
21090 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21091 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21092 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21093 I = ICA1
21094 ICA1 = ICB1
21095 ICB1 = I
21096 ENDIF
21097C remnant of hadron
21098 IF(INDXH.GT.0) THEN
21099 P1 = PSOFT1(1,INDXS)
21100 P2 = PSOFT1(2,INDXS)
21101 P3 = PSOFT1(3,INDXS)
21102 P4 = PSOFT1(4,INDXS)
21103 IJSI1(INDXS) = IREM
21104 ELSE
21105 P1 = PSOFT2(1,INDXS)
21106 P2 = PSOFT2(2,INDXS)
21107 P3 = PSOFT2(3,INDXS)
21108 P4 = PSOFT2(4,INDXS)
21109 IJSI2(INDXS) = IREM
21110 ENDIF
21111C registration
21112 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21113 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21114 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21115 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21116 & IREM,IPOS,SIGN(INDXS,INDXH)
21117 IUSED = 1
21118
21119C sea quark engaged in hard scattering, valence quarks treated
21120 ELSE IF(IVAL.EQ.0) THEN
21121 IF(INDXH.GT.0) THEN
21122 E1 = PSOFT1(4,INDXS)
21123 E2 = PSOFT1(4,INDXS+1)
21124 ELSE
21125 E1 = PSOFT2(4,INDXS)
21126 E2 = PSOFT2(4,INDXS+1)
21127 ENDIF
21128 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21129 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21130 IF(DT_RNDM(P1).LT.0.5D0) THEN
21131 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21132 ELSE
21133 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21134 ENDIF
21135 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21136 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21137 I = ICA1
21138 ICA1 = ICB1
21139 ICB1 = I
21140 ENDIF
21141 IF(INDXH.GT.0) THEN
21142 P1 = PSOFT1(1,INDXS)
21143 P2 = PSOFT1(2,INDXS)
21144 P3 = PSOFT1(3,INDXS)
21145 P4 = PSOFT1(4,INDXS)
21146 IJSI1(INDXS) = IVFL1
21147 ELSE
21148 P1 = PSOFT2(1,INDXS)
21149 P2 = PSOFT2(2,INDXS)
21150 P3 = PSOFT2(3,INDXS)
21151 P4 = PSOFT2(4,INDXS)
21152 IJSI2(INDXS) = IVFL1
21153 ENDIF
21154C registration
21155 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21156 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21157 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21158 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21159 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21160C
21161 IF(INDXH.GT.0) THEN
21162 P1 = PSOFT1(1,INDXS+1)
21163 P2 = PSOFT1(2,INDXS+1)
21164 P3 = PSOFT1(3,INDXS+1)
21165 P4 = PSOFT1(4,INDXS+1)
21166 IJSI1(INDXS+1) = IVFL2
21167 ELSE
21168 P1 = PSOFT2(1,INDXS+1)
21169 P2 = PSOFT2(2,INDXS+1)
21170 P3 = PSOFT2(3,INDXS+1)
21171 P4 = PSOFT2(4,INDXS+1)
21172 IJSI2(INDXS+1) = IVFL2
21173 ENDIF
21174C registration
21175 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21176 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21177 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21178 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21179 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21180C
21181 IF(IJH.LT.0) THEN
21182 ICB1 = ICC2
21183 ICA1 = ICC1
21184 ELSE
21185 ICB1 = ICC1
21186 ICA1 = ICC2
21187 ENDIF
21188 IF(INDXH.GT.0) THEN
21189 P1 = PSOFT1(1,INDXS+2)
21190 P2 = PSOFT1(2,INDXS+2)
21191 P3 = PSOFT1(3,INDXS+2)
21192 P4 = PSOFT1(4,INDXS+2)
21193 IJSI1(INDXS+2) = -IJH
21194 ELSE
21195 P1 = PSOFT2(1,INDXS+2)
21196 P2 = PSOFT2(2,INDXS+2)
21197 P3 = PSOFT2(3,INDXS+2)
21198 P4 = PSOFT2(4,INDXS+2)
21199 IJSI2(INDXS+2) = -IJH
21200 ENDIF
21201C registration
21202 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21203 & IHP,IGEN,ICA1,0,IPOS,1)
21204 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21205 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21206 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21207 IUSED = 3
21208C
21209C sea quark engaged in hard scattering, valences treated separately
21210 ELSE IF(IVAL.EQ.-1) THEN
21211 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21212 IF(IJH.GT.0) THEN
21213 ICC1 = ICB1
21214 ICB1 = ICA1
21215 ICA1 = ICC1
21216 ENDIF
21217 IF(INDXH.GT.0) THEN
21218 P1 = PSOFT1(1,INDXS)
21219 P2 = PSOFT1(2,INDXS)
21220 P3 = PSOFT1(3,INDXS)
21221 P4 = PSOFT1(4,INDXS)
21222 IJSI1(INDXS) = -IJH
21223 ELSE
21224 P1 = PSOFT2(1,INDXS)
21225 P2 = PSOFT2(2,INDXS)
21226 P3 = PSOFT2(3,INDXS)
21227 P4 = PSOFT2(4,INDXS)
21228 IJSI2(INDXS) = -IJH
21229 ENDIF
21230C registration
21231 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21232 & IHP,IGEN,ICA1,0,IPOS,1)
21233 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21234 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21235 & -IJH,IPOS,SIGN(INDXS,INDXH)
21236 IUSED = 1
21237 ELSE
21238 WRITE(LO,'(1X,A,2I5)')
21239 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21240 & IVAL,IJH
21241 CALL PHO_ABORT
21242 ENDIF
21243C
21244 IC1 = ICB1
21245 IC2 = 0
21246C
21247C gluon
21248C****************************************************************
21249C
21250C gluon from valence quarks
21251 ELSE
21252 IF(IVAL.EQ.1) THEN
21253C purely gluonic pomeron remnant
21254 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21255 IF(INDXH.GT.0) THEN
21256 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21257 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21258 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21259 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21260 IJSI1(INDXS) = 0
21261 ELSE
21262 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21263 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21264 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21265 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21266 IJSI2(INDXS) = 0
21267 ENDIF
21268 IFL1 = 21
21269 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21270 IF(DT_RNDM(P2).LT.0.5D0) THEN
21271 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21272 ELSE
21273 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21274 ENDIF
21275C registration
21276 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21277 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21278 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21279 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21280 & IFL1,IPOS,SIGN(INDXS,INDXH)
21281 IUSED = 2
21282C valence quark remnant
21283 ELSE
21284 IF(INDXH.GT.0) THEN
21285 E1 = PSOFT1(4,INDXS)
21286 E2 = PSOFT1(4,INDXS+1)
21287 ELSE
21288 E1 = PSOFT2(4,INDXS)
21289 E2 = PSOFT2(4,INDXS+1)
21290 ENDIF
21291 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21292 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21293 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21294 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21295 I = ICA1
21296 ICA1 = ICB1
21297 ICB1 = I
21298 ENDIF
21299 IF(DT_RNDM(P2).LT.0.5D0) THEN
21300 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21301 ELSE
21302 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21303 ENDIF
21304C remnant of hadron
21305 IF(INDXH.GT.0) THEN
21306 P1 = PSOFT1(1,INDXS)
21307 P2 = PSOFT1(2,INDXS)
21308 P3 = PSOFT1(3,INDXS)
21309 P4 = PSOFT1(4,INDXS)
21310 IJSI1(INDXS) = IFL1
21311 ELSE
21312 P1 = PSOFT2(1,INDXS)
21313 P2 = PSOFT2(2,INDXS)
21314 P3 = PSOFT2(3,INDXS)
21315 P4 = PSOFT2(4,INDXS)
21316 IJSI2(INDXS) = IFL1
21317 ENDIF
21318C registration
21319 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21320 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21321 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21322 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21323 & IFL1,IPOS,SIGN(INDXS,INDXH)
21324C
21325 IF(INDXH.GT.0) THEN
21326 P1 = PSOFT1(1,INDXS+1)
21327 P2 = PSOFT1(2,INDXS+1)
21328 P3 = PSOFT1(3,INDXS+1)
21329 P4 = PSOFT1(4,INDXS+1)
21330 IJSI1(INDXS+1) = IFL2
21331 ELSE
21332 P1 = PSOFT2(1,INDXS+1)
21333 P2 = PSOFT2(2,INDXS+1)
21334 P3 = PSOFT2(3,INDXS+1)
21335 P4 = PSOFT2(4,INDXS+1)
21336 IJSI2(INDXS+1) = IFL2
21337 ENDIF
21338C registration
21339 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21340 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21341 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21342 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21343 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21344 IUSED = 2
21345 ENDIF
21346C
21347C gluon from sea quarks connected with valence quarks
21348 ELSE IF(IVAL.EQ.0) THEN
21349 IF(INDXH.GT.0) THEN
21350 E1 = PSOFT1(4,INDXS)
21351 E2 = PSOFT1(4,INDXS+1)
21352 ELSE
21353 E1 = PSOFT2(4,INDXS)
21354 E2 = PSOFT2(4,INDXS+1)
21355 ENDIF
21356 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21357 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21358 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21359 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21360 I = ICA1
21361 ICA1 = ICB1
21362 ICB1 = I
21363 ENDIF
21364 IF(DT_RNDM(P3).LT.0.5D0) THEN
21365 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21366 ELSE
21367 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21368 ENDIF
21369C remnant of hadron
21370 IF(INDXH.GT.0) THEN
21371 P1 = PSOFT1(1,INDXS)
21372 P2 = PSOFT1(2,INDXS)
21373 P3 = PSOFT1(3,INDXS)
21374 P4 = PSOFT1(4,INDXS)
21375 IJSI1(INDXS) = IFL1
21376 ELSE
21377 P1 = PSOFT2(1,INDXS)
21378 P2 = PSOFT2(2,INDXS)
21379 P3 = PSOFT2(3,INDXS)
21380 P4 = PSOFT2(4,INDXS)
21381 IJSI2(INDXS) = IFL1
21382 ENDIF
21383C registration
21384 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21385 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21386 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21387 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21388 & IFL1,IPOS,SIGN(INDXS,INDXH)
21389C
21390 IF(INDXH.GT.0) THEN
21391 P1 = PSOFT1(1,INDXS+1)
21392 P2 = PSOFT1(2,INDXS+1)
21393 P3 = PSOFT1(3,INDXS+1)
21394 P4 = PSOFT1(4,INDXS+1)
21395 IJSI1(INDXS+1) = IFL2
21396 ELSE
21397 P1 = PSOFT2(1,INDXS+1)
21398 P2 = PSOFT2(2,INDXS+1)
21399 P3 = PSOFT2(3,INDXS+1)
21400 P4 = PSOFT2(4,INDXS+1)
21401 IJSI2(INDXS+1) = IFL2
21402 ENDIF
21403C registration
21404 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21405 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21406 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21407 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21408 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21409 IF(IPAMDL(18).EQ.0) THEN
21410C sea quark pair
21411 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21412 IF(ICC1.GT.0) THEN
21413 IFL1 = ABS(IFL1)
21414 IFL2 = -IFL1
21415 ELSE
21416 IFL1 = -ABS(IFL1)
21417 IFL2 = -IFL1
21418 ENDIF
21419 IF(DT_RNDM(P4).LT.0.5D0) THEN
21420 ICB1 = ICC2
21421 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21422 ELSE
21423 ICA1 = ICC1
21424 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21425 ENDIF
21426 IF(INDXH.GT.0) THEN
21427 P1 = PSOFT1(1,INDXS+2)
21428 P2 = PSOFT1(2,INDXS+2)
21429 P3 = PSOFT1(3,INDXS+2)
21430 P4 = PSOFT1(4,INDXS+2)
21431 IJSI1(INDXS+2) = IFL1
21432 ELSE
21433 P1 = PSOFT2(1,INDXS+2)
21434 P2 = PSOFT2(2,INDXS+2)
21435 P3 = PSOFT2(3,INDXS+2)
21436 P4 = PSOFT2(4,INDXS+2)
21437 IJSI2(INDXS+2) = IFL1
21438 ENDIF
21439C registration
21440 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21441 & IHP,IGEN,ICA1,0,IPOS,1)
21442 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21443 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21444 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21445C
21446 IF(INDXH.GT.0) THEN
21447 P1 = PSOFT1(1,INDXS+3)
21448 P2 = PSOFT1(2,INDXS+3)
21449 P3 = PSOFT1(3,INDXS+3)
21450 P4 = PSOFT1(4,INDXS+3)
21451 IJSI1(INDXS+3) = IFL2
21452 ELSE
21453 P1 = PSOFT2(1,INDXS+3)
21454 P2 = PSOFT2(2,INDXS+3)
21455 P3 = PSOFT2(3,INDXS+3)
21456 P4 = PSOFT2(4,INDXS+3)
21457 IJSI2(INDXS+3) = IFL2
21458 ENDIF
21459C registration
21460 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21461 & IHP,IGEN,ICB1,0,IPOS,1)
21462 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21463 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21464 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21465 IUSED = 4
21466 ELSE
21467 IUSED = 2
21468 ENDIF
21469C
21470C gluon from independent sea quarks
21471 ELSE IF(IVAL.EQ.-1) THEN
21472 IF(IPAMDL(18).EQ.0) THEN
21473 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21474 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21475 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21476 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21477 I = ICA1
21478 ICA1 = ICB1
21479 ICB1 = I
21480 ENDIF
21481 IF(DT_RNDM(P1).LT.0.5D0) THEN
21482 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21483 ELSE
21484 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21485 ENDIF
21486C remainder of hadron
21487 IF(INDXH.GT.0) THEN
21488 P1 = PSOFT1(1,INDXS)
21489 P2 = PSOFT1(2,INDXS)
21490 P3 = PSOFT1(3,INDXS)
21491 P4 = PSOFT1(4,INDXS)
21492 IJSI1(INDXS) = IFL1
21493 ELSE
21494 P1 = PSOFT2(1,INDXS)
21495 P2 = PSOFT2(2,INDXS)
21496 P3 = PSOFT2(3,INDXS)
21497 P4 = PSOFT2(4,INDXS)
21498 IJSI2(INDXS) = IFL1
21499 ENDIF
21500C registration
21501 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21502 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21503 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21504 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21505 & IFL1,IPOS,SIGN(INDXS,INDXH)
21506C remnant of sea
21507 IF(INDXH.GT.0) THEN
21508 P1 = PSOFT1(1,INDXS-1)
21509 P2 = PSOFT1(2,INDXS-1)
21510 P3 = PSOFT1(3,INDXS-1)
21511 P4 = PSOFT1(4,INDXS-1)
21512 IJSI1(INDXS-1) = IFL2
21513 ELSE
21514 P1 = PSOFT2(1,INDXS-1)
21515 P2 = PSOFT2(2,INDXS-1)
21516 P3 = PSOFT2(3,INDXS-1)
21517 P4 = PSOFT2(4,INDXS-1)
21518 IJSI2(INDXS-1) = IFL2
21519 ENDIF
21520C registration
21521 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21522 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21523 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21524 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21525 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21526 IUSED = 2
21527 ELSE
21528 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21529 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21530 & 'PHO_HARREM: no spectator added:(INDXS)',
21531 & SIGN(INDXS,INDXH)
21532 IUSED = 0
21533 ENDIF
21534C
21535 ELSE
21536 WRITE(LO,'(1X,A,2I5)')
21537 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21538 & IVAL,IJH
21539 CALL PHO_ABORT
21540 ENDIF
21541 IC1 = ICC1
21542 IC2 = ICC2
21543 ENDIF
21544 END
21545
21546*$ CREATE PHO_HARDIR.FOR
21547*COPY PHO_HARDIR
21548CDECK ID>, PHO_HARDIR
21549 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21550 & IREJ)
21551C**********************************************************************
21552C
21553C parton orientated formulation of direct scattering processes
21554C
21555C input:
21556C
21557C output: II particle combination (1..4)
21558C IVAL1,2 0 no valence quarks engaged
21559C 1 valence quarks engaged
21560C MSPAR1,2 number of realized soft partons
21561C MHPAR1,2 number of realized hard partons
21562C IREJ 1 failure
21563C 0 success
21564C
21565C**********************************************************************
21566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21567 SAVE
21568
21569C input/output channels
21570 INTEGER LI,LO
21571 COMMON /POINOU/ LI,LO
21572C event debugging information
21573 INTEGER NMAXD
21574 PARAMETER (NMAXD=100)
21575 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21576 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21577 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21578 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21579C model switches and parameters
21580 CHARACTER*8 MDLNA
21581 INTEGER ISWMDL,IPAMDL
21582 DOUBLE PRECISION PARMDL
21583 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21584C hard scattering parameters used for most recent hard interaction
21585 INTEGER NFbeta,NF
21586 DOUBLE PRECISION ALQCD2,BQCD
21587 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21588C data of c.m. system of Pomeron / Reggeon exchange
21589 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21590 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21591 & SIDP,CODP,SIFP,COFP
21592 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21593 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21594 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21595C obsolete cut-off information
21596 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21597 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21598C hard cross sections and MC selection weights
21599 INTEGER Max_pro_2
21600 PARAMETER ( Max_pro_2 = 16 )
21601 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21602 & MH_acc_1,MH_acc_2
21603 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21604 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21605 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21606 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21607 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21608 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21609C data on most recent hard scattering
21610 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21611 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21612 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21613 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21614 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21615 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21616 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21617 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21618 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21619C light-cone x fractions and c.m. momenta of soft cut string ends
21620 INTEGER MAXSOF
21621 PARAMETER ( MAXSOF = 50 )
21622 INTEGER IJSI2,IJSI1
21623 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21624 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21625 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21626 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21627C hard scattering data
21628 INTEGER MSCAHD
21629 PARAMETER ( MSCAHD = 50 )
21630 INTEGER LSCAHD,LSC1HD,LSIDX,
21631 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21632 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21633 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21634 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21635 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21636 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21637 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21638 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21639 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21640C internal rejection counters
21641 INTEGER NMXJ
21642 PARAMETER (NMXJ=60)
21643 CHARACTER*10 REJTIT
21644 INTEGER IFAIL
21645 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21646
21647 DIMENSION P1(4),P2(4),PD1(-6:6)
21648
21649 PARAMETER ( TINY = 1.D-10 )
21650
21651 ITRY = 0
21652 NTRY = 10
21653 LSC1HD = 0
21654 LSIDX(1) = 1
21655
21656C check phase space
21657 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21658 IFAIL(18) = IFAIL(18)+1
21659 IREJ = 50
21660 RETURN
21661 ENDIF
21662
21663 AS = (PARMDL(160+II)/ECMP)**2
21664 AH = (2.D0*PTWANT/ECMP)**2
21665
21666 ALNS = LOG(AS)
21667 ALNH = LOG(AH)
21668
21669 XMAX = MAX(TINY,1.D0-AS)
21670 Z1MAX = LOG(XMAX)
21671 Z1DIF = Z1MAX-ALNH
21672C
21673C main loop to select hard and soft parton kinematics
21674C -----------------------------------------------------
21675 120 CONTINUE
21676 IREJ = 0
21677 ITRY = ITRY+1
21678 LSC1HD = LSC1HD+1
21679 IF(ITRY.GT.1) THEN
21680 IFAIL(17) = IFAIL(17)+1
21681 IF(ITRY.GE.NTRY) THEN
21682 IREJ = 1
21683 GOTO 450
21684 ENDIF
21685 ENDIF
21686 LINE = 0
21687 LSCAHD = 0
21688 XSS1 = 0.D0
21689 XSS2 = 0.D0
21690 MSPAR1 = 0
21691 MSPAR2 = 0
21692
21693C select hard V,X
21694 CALL PHO_HARSCA(1,II)
21695 XSS1 = XSS1+X1
21696 XSS2 = XSS2+X2
21697C debug output
21698 IF(IDEB(25).GE.20) THEN
21699 WRITE(LO,'(1X,A,2E12.4,2I5)')
21700 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21701 & AS,XMAX,MSPR,ITRY
21702 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21703 & X1,X2,XSS1,XSS2
21704 ENDIF
21705
21706 IF(MSPR.LE.11) THEN
21707 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21708 ELSE IF(MSPR.LE.13) THEN
21709 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21710 ENDIF
21711
21712C fill /POHSLT/
21713 LSCAHD = 1
21714 LSIDX(1) = 1
21715 XHD(1,1) = X1
21716 XHD(1,2) = X2
21717 X0HD(1,1) = X1
21718 X0HD(1,2) = X2
21719 VHD(1) = V
21720 ETAHD(1,1) = ETAC
21721 ETAHD(1,2) = ETAD
21722 PTHD(1) = PT
21723 Q2SCA(1,1) = QQPD
21724 Q2SCA(1,2) = QQPD
21725 NPROHD(1) = MSPR
21726 NBRAHD(1,1)= IDPDG1
21727 NBRAHD(1,2)= IDPDG2
21728 DO 45 I=1,4
21729 PPH(I,1) = PHI1(I)
21730 PPH(I,2) = PHI2(I)
21731 PPH(4+I,1) = PHO1(I)
21732 PPH(4+I,2) = PHO2(I)
21733 45 CONTINUE
21734C valence quarks
21735 IVAL1 = IV1
21736 IVAL2 = IV2
21737 PDFVA(1,1) = 0.D0
21738 PDFVA(1,2) = 0.D0
21739C parton flavours
21740 IF(MSPR.LE.11) THEN
21741 NINHD(1,1) = IDPDG1
21742 NINHD(1,2) = IB
21743 PDFVA(1,2) = PDF2(IB)
21744 KHDIR = 1
21745 ELSE IF(MSPR.LE.13) THEN
21746 NINHD(1,1) = IA
21747 PDFVA(1,1) = PDF1(IA)
21748 NINHD(1,2) = IDPDG2
21749 KHDIR = 2
21750 ELSE
21751 NINHD(1,1) = IDPDG1
21752 NINHD(1,2) = IDPDG2
21753 KHDIR = 3
21754 ENDIF
21755 N0INHD(1,1) = NINHD(1,1)
21756 N0INHD(1,2) = NINHD(1,2)
21757 N0IVAL(1,1) = IVAL1
21758 N0IVAL(1,2) = IVAL2
21759 NOUTHD(1,1) = IC
21760 NOUTHD(1,2) = ID
21761
21762C reweight according to photon virtuality
21763 IF(MSPR.NE.14) THEN
21764 IF(IPAMDL(115).GE.1) THEN
21765 WGX = 1.D0
21766 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21767 QQPD = Q2SCA(1,2)
21768 IF(IPAMDL(115).EQ.1) THEN
21769 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21770 WGX = 0.D0
21771 ELSE
21772 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21773 & /LOG(QQPD/PARMDL(144))
21774 ENDIF
21775 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21776 ELSE IF(IPAMDL(115).EQ.2) THEN
21777 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21778 WGX = PD1(IB)/PDFVA(1,2)
21779 ENDIF
21780 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21781 & .AND.(IDPDG1.EQ.22)) THEN
21782 QQPD = Q2SCA(1,1)
21783 IF(IPAMDL(115).EQ.1) THEN
21784 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21785 WGX = 0.D0
21786 ELSE
21787 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21788 & /LOG(QQPD/PARMDL(144))
21789 ENDIF
21790 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21791 ELSE IF(IPAMDL(115).EQ.2) THEN
21792 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21793 WGX = PD1(IA)/PDFVA(1,1)
21794 ENDIF
21795 ENDIF
21796
21797 IF(IDEB(25).GE.25)
21798 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21799 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21800 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21801
21802 IF(WGX.LT.DT_RNDM(WGX)) THEN
21803 IREJ = 50
21804 RETURN
21805 ENDIF
21806
21807 IF(WGX.GT.1.01D0)
21808 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21809 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21810 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21811
21812 ENDIF
21813 ENDIF
21814
21815C generate ISR
21816 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21817 IF(IPAMDL(109).EQ.1) THEN
21818 Q2H = PARMDL(93)*PT**2
21819 ELSE
21820 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21821 ENDIF
21822 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
21823 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
21824 DO 42 J=1,4
21825 P1(J) = PPH(4+J,1)
21826 P2(J) = PPH(4+J,2)
21827 42 CONTINUE
21828 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21829 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21830 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21831 XSS1 = XSS1+XISR1-XHD(1,1)
21832 XSS2 = XSS2+XISR2-XHD(1,2)
21833 NINHD(1,1) = IFL1
21834 NINHD(1,2) = IFL2
21835 XHD(1,1) = XISR1
21836 XHD(1,2) = XISR2
21837 ELSE
21838 IFL1 = NINHD(1,1)
21839 IFL2 = NINHD(1,2)
21840 ENDIF
21841 NIVAL(1,1) = IVAL1
21842 NIVAL(1,2) = IVAL2
21843
21844C add photon/hadron remnant
21845
21846C incoming gluon
21847 IF(IFL2.EQ.0) THEN
21848 XMAXX = 1.D0 - XSS2 - AS
21849 XMAXH = MIN(XMAXX,PARMDL(44))
21850 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21851 IVAL2 = 1
21852 MSPAR1 = 0
21853 MSPAR2 = 2
21854 MHPAR1 = 1
21855 MHPAR2 = 1
21856 ELSE IF(IFL1.EQ.0) THEN
21857 XMAXX = 1.D0 - XSS1 - AS
21858 XMAXH = MIN(XMAXX,PARMDL(44))
21859 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21860 IVAL1 = 1
21861 MSPAR1 = 2
21862 MSPAR2 = 0
21863 MHPAR1 = 1
21864 MHPAR2 = 1
21865
21866C incoming quark
21867 ELSE IF(ABS(IFL2).LE.12) THEN
21868 IF(IVAL2.EQ.1) THEN
21869 XS2(1) = 1.D0 - XSS2
21870 MSPAR1 = 0
21871 MSPAR2 = 1
21872 MHPAR1 = 1
21873 MHPAR2 = 1
21874 ELSE
21875 XMAXX = 1.D0 - XSS2 - AS
21876 XMAXH = MIN(XMAXX,PARMDL(44))
21877 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21878 MSPAR1 = 0
21879 MSPAR2 = 3
21880 MHPAR1 = 1
21881 MHPAR2 = 1
21882 ENDIF
21883 ELSE IF(ABS(IFL1).LE.12) THEN
21884 IF(IVAL1.EQ.1) THEN
21885 XS1(1) = 1.D0 - XSS1
21886 MSPAR1 = 1
21887 MSPAR2 = 0
21888 MHPAR1 = 1
21889 MHPAR2 = 1
21890 ELSE
21891 XMAXX = 1.D0 - XSS1 - AS
21892 XMAXH = MIN(XMAXX,PARMDL(44))
21893 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21894 MSPAR1 = 3
21895 MSPAR2 = 0
21896 MHPAR1 = 1
21897 MHPAR2 = 1
21898 ENDIF
21899
21900C double direct process
21901 ELSE IF(MSPR.EQ.14) THEN
21902 MSPAR1 = 0
21903 MSPAR2 = 0
21904 MHPAR1 = 1
21905 MHPAR2 = 1
21906
21907C unknown process
21908 ELSE
21909 WRITE(LO,'(/1X,A,I3/)')
21910 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21911 CALL PHO_ABORT
21912 ENDIF
21913
21914 IF(IREJ.NE.0) THEN
21915 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21916 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21917 GOTO 120
21918 ENDIF
21919
21920C soft particle momenta
21921 IF(MSPAR1.GT.0) THEN
21922 DO 50 I=1,MSPAR1
21923 PSOFT1(1,I) = 0.D0
21924 PSOFT1(2,I) = 0.D0
21925 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21926 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21927 50 CONTINUE
21928 ENDIF
21929 IF(MSPAR2.GT.0) THEN
21930 DO 55 I=1,MSPAR2
21931 PSOFT2(1,I) = 0.D0
21932 PSOFT2(2,I) = 0.D0
21933 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21934 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21935 55 CONTINUE
21936 ENDIF
21937C process counting
21938 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21939 KSOFT = MAX(MSPAR1,MSPAR2)
21940 KHARD = MAX(MHPAR1,MHPAR2)
21941C debug output
21942 IF(IDEB(25).GE.10) THEN
21943 WRITE(LO,'(/1X,A,2I3,3I5)')
21944 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21945 & IVAL1,IVAL2,MSPR,ITRY,NTRY
21946 IF(MSPAR1.GT.0) THEN
21947 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21948 DO 105 I=1,MSPAR1
21949 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21950 105 CONTINUE
21951 ENDIF
21952 IF(MSPAR2.GT.0) THEN
21953 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21954 DO 106 I=1,MSPAR2
21955 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21956 106 CONTINUE
21957 ENDIF
21958 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21959 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21960 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
21961 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21962 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21963 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21964 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
21965 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21966 ENDIF
21967 RETURN
21968
21969 450 CONTINUE
21970 IFAIL(16) = IFAIL(16)+1
21971 IF(IDEB(25).GE.2) THEN
21972 WRITE(LO,'(1X,A,3I5)')
21973 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21974 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21975 IF(IDEB(25).GE.5) THEN
21976 CALL PHO_PREVNT(0)
21977 ELSE
21978 CALL PHO_PREVNT(-1)
21979 ENDIF
21980 ENDIF
21981
21982 END
21983
21984*$ CREATE PHO_POMSCA.FOR
21985*COPY PHO_POMSCA
21986CDECK ID>, PHO_POMSCA
21987 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21988 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21989C**********************************************************************
21990C
21991C parton orientated formulation of soft and hard inelastic events
21992C
21993C
21994C input: II particle combiantion (1..4)
21995C MSPOM number of soft pomerons
21996C MHPOM number of semihard pomerons
21997C MSREG number of soft reggeons
21998C
21999C output: IVAL1,2 0 no valence quark engaged
22000C otherwise: position of valence quark engaged
22001C neg.number: gluon connected to valence quark
22002C by color flow
22003C MSPAR1,2 number of realized soft partons
22004C MHPAR1,2 number of realized hard partons
22005C IREJ 1 failure
22006C 0 success
22007C
22008C**********************************************************************
22009 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22010 SAVE
22011
22012 PARAMETER (TINY = 1.D-30 )
22013
22014C input/output channels
22015 INTEGER LI,LO
22016 COMMON /POINOU/ LI,LO
22017C event debugging information
22018 INTEGER NMAXD
22019 PARAMETER (NMAXD=100)
22020 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22021 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22022 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22023 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22024C model switches and parameters
22025 CHARACTER*8 MDLNA
22026 INTEGER ISWMDL,IPAMDL
22027 DOUBLE PRECISION PARMDL
22028 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22029C general process information
22030 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22031 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22032C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22033 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22034 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22035 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22036 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22037C event weights and generated cross section
22038 INTEGER IPOWGC,ISWCUT,IVWGHT
22039 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22040 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22041 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22042C hard cross sections and MC selection weights
22043 INTEGER Max_pro_2
22044 PARAMETER ( Max_pro_2 = 16 )
22045 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22046 & MH_acc_1,MH_acc_2
22047 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22048 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22049 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22050 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22051 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22052 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22053C hard scattering parameters used for most recent hard interaction
22054 INTEGER NFbeta,NF
22055 DOUBLE PRECISION ALQCD2,BQCD
22056 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22057C data of c.m. system of Pomeron / Reggeon exchange
22058 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22059 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22060 & SIDP,CODP,SIFP,COFP
22061 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22062 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22063 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22064C obsolete cut-off information
22065 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22066 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22067C some hadron information, will be deleted in future versions
22068 INTEGER NFS
22069 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22070 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22071C data on most recent hard scattering
22072 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22073 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22074 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22075 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22076 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22077 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22078 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22079 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22080 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22081C light-cone x fractions and c.m. momenta of soft cut string ends
22082 INTEGER MAXSOF
22083 PARAMETER ( MAXSOF = 50 )
22084 INTEGER IJSI2,IJSI1
22085 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22086 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22087 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22088 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22089C hard scattering data
22090 INTEGER MSCAHD
22091 PARAMETER ( MSCAHD = 50 )
22092 INTEGER LSCAHD,LSC1HD,LSIDX,
22093 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22094 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22095 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22096 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22097 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22098 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22099 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22100 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22101 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22102C table of particle indices for recursive PHOJET calls
22103 INTEGER MAXIPX
22104 PARAMETER ( MAXIPX = 100 )
22105 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22106 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22107 & IPOIX1,IPOIX2,IPOIX3
22108C internal rejection counters
22109 INTEGER NMXJ
22110 PARAMETER (NMXJ=60)
22111 CHARACTER*10 REJTIT
22112 INTEGER IFAIL
22113 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22114
22115 DIMENSION P1(4),P2(4),PD1(-6:6)
22116
22117 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22118 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22119
22120 ITRY = 0
22121 NTRY = 10
22122 IREJ = 0
22123 INMAX = 10
22124 MHARD = MHPOM
22125
22126C phase space limitation (single hard valence-valence quark scattering)
22127 IF(MHPOM.GT.0) THEN
22128 Emin = 2.D0*PTWANT + 0.2D0
22129 IF(ECMP.LT.Emin) THEN
22130 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22131 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22132 IREJ = 50
22133 IFAIL(6) = IFAIL(6) + 1
22134 RETURN
22135 ENDIF
22136 ENDIF
22137
22138 SAS = PARMDL(160+II)/ECMP
22139 SAH = 2.D0*PTWANT/ECMP
22140 AS = SAS**2
22141 AH = SAH**2
22142
22143C save energy for leading particle effect
22144 XMAXP1 = 1.D0
22145 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22146 XMAXP2 = 1.D0
22147 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22148
22149C
22150C main loop to select hard and soft parton kinematics
22151C -----------------------------------------------------
22152 IFAIL(31) = IFAIL(31)+MHARD
22153 20 CONTINUE
22154 IREJ = 0
22155 IHARD = 0
22156 LSC1HD = 0
22157 ITRY = ITRY+1
22158 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22159 IF(ITRY.GE.NTRY) THEN
22160 IREJ = 1
22161 GOTO 450
22162 ENDIF
22163 LINE = 0
22164 LSCAHD = 0
22165 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22166 XSS1 = MAX(0.D0,1.D0-XPSUB)
22167 XSS2 = MAX(0.D0,1.D0-XTSUB)
22168 ELSE
22169 XSS1 = 0.D0
22170 XSS2 = 0.D0
22171 ENDIF
22172 22 continue
22173
22174C partons needed to construct soft/hard interactions
22175 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22176 MSPAR2 = MSPAR1
22177 MHPAR1 = MHPOM
22178 MHPAR2 = MHPOM
22179
22180C number of strings
22181 MSCHA = 2*MSPOM+MSREG
22182 MHCHA = 2*MHPOM
22183
22184 KSOFT = MSCHA
22185 KHARD = MHCHA
22186
22187C check actual phase space limit
22188 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22189 IF(XX.GE.1.D0) THEN
22190 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22191 & 'PHO_POMSCA: internal kin. rejection ',
22192 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22193 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22194 if(MSPOM+MSREG+MHPOM.gt.1) then
22195 if(MSREG.gt.0) then
22196 MSREG = MSREG-1
22197 else if(MSPOM.gt.0) THEN
22198 MSPOM = MSPOM-1
22199 else if(MHPOM.gt.1) then
22200 MHPOM = MHPOM-1
22201 endif
22202 goto 22
22203 endif
22204 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22205 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22206 IREJ = 50
22207 IFAIL(6) = IFAIL(6) + 1
22208 RETURN
22209 ENDIF
22210
22211 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22212 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22213
22214C very low energy phase space restriction
22215 if(MHARD.gt.0) then
22216 if((XMAXX1*XMAXX2.le.AH)) then
22217 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22218 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22219 IREJ = 50
22220 IFAIL(6) = IFAIL(6) + 1
22221 RETURN
22222 endif
22223 endif
22224
22225 AS = MAX(AS,PSOMIN/PCMP)
22226 ALNS = LOG(AS)
22227 ALNH = LOG(AH)
22228 Z1MAX = LOG(XMAXX1)
22229 Z2MAX = LOG(XMAXX2)
22230 Z1DIF = Z1MAX+Z2MAX-ALNH
22231 Z2DIF = Z1DIF
22232 PTMAX = 0.D0
22233C
22234C select hard parton momenta
22235C ------------------- begin of inner loop -------------------
22236 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22237 IF(MHARD.GT.MSCAHD) THEN
22238 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22239 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22240 IREJ = 1
22241 RETURN
22242 ENDIF
22243 DO 11 NN=1,MHARD
22244C
22245C generate one resolved hard scattering
22246C
22247C high-pt option
22248 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22249 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22250 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22251 XSCUT = HSig(9)
22252 AHS = AH
22253 ALNHS = ALNH
22254 Z1DIFS = Z1DIF
22255 Z2DIFS = Z2DIF
22256 AH = (2.D0*PTWANT/ECMP)**2
22257 ALNH = LOG(AH)
22258 Z1DIF = Z1MAX+Z2MAX-ALNH
22259 Z2DIF = Z1DIF
22260 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22261 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22262 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22263 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22264 IREJ = 5
22265 RETURN
22266 ENDIF
22267 CALL PHO_HARSCA(2,II)
22268 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22269 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22270 AH = AHS
22271 ALNH = ALNHS
22272 Z1DIF = Z1DIFS
22273 Z2DIF = Z2DIFS
22274 IPOWGC(4+II) = IPOWGC(4+II)+1
22275 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22276C minimum bias option
22277 ELSE
22278 CALL PHO_HARSCA(2,II)
22279 ENDIF
22280
22281C fill /POHSLT/
22282 LSIDX(NN) = NN
22283 LSCAHD = NN
22284 XHD(NN,1) = X1
22285 XHD(NN,2) = X2
22286 X0HD(NN,1) = X1
22287 X0HD(NN,2) = X2
22288 VHD(NN) = V
22289 ETAHD(NN,1) = ETAC
22290 ETAHD(NN,2) = ETAD
22291 PTHD(NN) = PT
22292 NPROHD(NN) = MSPR
22293 Q2SCA(NN,1) = QQPD
22294 Q2SCA(NN,2) = QQPD
22295 PDFVA(NN,1) = PDF1(IA)
22296 PDFVA(NN,2) = PDF2(IB)
22297 NINHD(NN,1) = IA
22298 NINHD(NN,2) = IB
22299 N0INHD(NN,1) = IA
22300 N0INHD(NN,2) = IB
22301 NIVAL(NN,1) = IV1
22302 NIVAL(NN,2) = IV2
22303 N0IVAL(NN,1) = IV1
22304 N0IVAL(NN,2) = IV2
22305 NOUTHD(NN,1) = IC
22306 NOUTHD(NN,2) = ID
22307 NBRAHD(NN,1) = IDPDG1
22308 NBRAHD(NN,2) = IDPDG2
22309 I3 = 8*(NN-1)
22310 I4 = 8*(NN-1)+4
22311 DO 50 I=1,4
22312 PPH(I3+I,1) = PHI1(I)
22313 PPH(I3+I,2) = PHI2(I)
22314 PPH(I4+I,1) = PHO1(I)
22315 PPH(I4+I,2) = PHO2(I)
22316 50 CONTINUE
22317
22318 11 CONTINUE
22319
22320C sort according to pt-hat
22321 DO 12 NN=1,MHARD
22322 PTMX = PTHD(LSIDX(NN))
22323 IPTM = NN
22324 DO 13 I=NN+1,MHARD
22325 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22326 IPTM = I
22327 PTMX = PTHD(LSIDX(I))
22328 ENDIF
22329 13 CONTINUE
22330 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22331 12 CONTINUE
22332 IPTM = LSIDX(1)
22333
22334C copy partons, generate ISR
22335 DO 15 L=1,MHARD
22336 NN = LSIDX(L)
22337 XSSS1 = XSS1+XHD(NN,1)
22338 XSSS2 = XSS2+XHD(NN,2)
22339C debug output
22340 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22341 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22342 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22343C check phase space
22344 IF( (XSSS1.GT.XMAXX1)
22345 & .OR.(XSSS2.GT.XMAXX2)
22346 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22347 IF(IHARD.EQ.0) THEN
22348 IF(ISWMDL(2).NE.1) GOTO 20
22349 MHPOM = 0
22350 MSPOM = 1
22351 MSREG = 0
22352 ENDIF
22353 GOTO 199
22354 ENDIF
22355
22356C reweight according to photon virtuality
22357 IF(IPAMDL(115).GE.1) THEN
22358 QQPD = Q2SCA(NN,1)
22359 WGX = 1.D0
22360 IF(IDPDG1.EQ.22) THEN
22361 IF(IPAMDL(115).EQ.1) THEN
22362 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22363 WG1 = 0.D0
22364 ELSE
22365 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22366 & /LOG(QQPD/PARMDL(144))
22367 ENDIF
22368 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22369 ELSE IF(IPAMDL(115).EQ.2) THEN
22370 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22371 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22372 ENDIF
22373 WGX = WG1
22374 ENDIF
22375 QQPD = Q2SCA(NN,2)
22376 IF(IDPDG2.EQ.22) THEN
22377 IF(IPAMDL(115).EQ.1) THEN
22378 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22379 WG1 = 0.D0
22380 ELSE
22381 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22382 & /LOG(QQPD/PARMDL(144))
22383 ENDIF
22384 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22385 ELSE IF(IPAMDL(115).EQ.2) THEN
22386 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22387 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22388 ENDIF
22389 WGX = WGX*WG1
22390 ENDIF
22391
22392 IF(IDEB(24).GE.25)
22393 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22394 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22395 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22396
22397 IF(WGX.LT.DT_RNDM(WGX)) THEN
22398 IF(L.EQ.1) THEN
22399 IREJ = 50
22400 RETURN
22401 ELSE
22402 GOTO 199
22403 ENDIF
22404 ENDIF
22405
22406 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22407 & 'PHO_POMSCA: ',
22408 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22409 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22410
22411 ENDIF
22412
22413C generate ISR
22414 IF((ISWMDL(8).GE.2)
22415 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22416 IF(IPAMDL(109).EQ.1) THEN
22417 Q2H = PARMDL(93)*PTHD(NN)**2
22418 ELSE
22419 Q2H = -PARMDL(93)*VHD(NN)
22420 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22421 ENDIF
22422 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22423 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22424 I3 = 8*NN-4
22425 DO 42 J=1,4
22426 P1(J) = PPH(I3+J,1)
22427 P2(J) = PPH(I3+J,2)
22428 42 CONTINUE
22429 IF(IDEB(24).GE.10)
22430 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22431 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22432 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22433 J = NN
22434 IF(L.EQ.1) J = -NN
22435 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22436 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22437 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22438 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22439 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22440 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22441 NINHD(NN,1) = IFL1
22442 NINHD(NN,2) = IFL2
22443 XHD(NN,1) = XISR1
22444 XHD(NN,2) = XISR2
22445 ENDIF
22446
22447C check phase space
22448 IF( (XSSS1.GT.XMAXX1)
22449 & .OR.(XSSS2.GT.XMAXX2)
22450 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22451 IF(IHARD.EQ.0) THEN
22452 IF(ISWMDL(2).NE.1) GOTO 20
22453 MHPOM = 0
22454 MSPOM = 1
22455 MSREG = 0
22456 ENDIF
22457 GOTO 199
22458 ENDIF
22459
22460C leave energy for leading particle effect
22461 IF((IHARD.GT.0).AND.
22462 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22463 GOTO 199
22464 endif
22465
22466C hard scattering accepted
22467 IHARD = IHARD+1
22468 XSS1 = XSSS1
22469 XSS2 = XSSS2
22470 IFAIL(31) = IFAIL(31)-1
22471
22472 15 CONTINUE
22473
22474C ------------------- end of inner (hard) loop -------------------
22475 199 CONTINUE
22476
22477 MHPOM = IHARD
22478 MHPAR1 = IHARD
22479 MHPAR2 = IHARD
22480
22481C count valences involved in hard scattering
22482 IVAL1 = 0
22483 IVAL2 = 0
22484 DO 17 L=1,IHARD
22485 NN = LSIDX(L)
22486 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22487 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22488 17 CONTINUE
22489
22490 IQUA1 = 0
22491 IQUA2 = 0
22492 IVGLU1 = 0
22493 IVGLU2 = 0
22494 DO 18 L=1,IHARD
22495 NN = LSIDX(L)
22496
22497C photon, pomeron valences
22498 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22499 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22500 NIVAL(NN,1) = 1
22501 IVAL1 = NN
22502 ENDIF
22503 ENDIF
22504 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22505 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22506 NIVAL(NN,2) = 1
22507 IVAL2 = NN
22508 ENDIF
22509 ENDIF
22510
22511C total number of quarks
22512 IF(NINHD(NN,1).NE.0) THEN
22513 IQUA1 = IQUA1+1
22514 ELSE IF(IVGLU1.EQ.0) THEN
22515 IVGLU1 = NN
22516 ENDIF
22517 IF(NINHD(NN,2).NE.0) THEN
22518 IQUA2 = IQUA2+1
22519 ELSE IF(IVGLU2.EQ.0) THEN
22520 IVGLU2 = NN
22521 ENDIF
22522 18 CONTINUE
22523
22524C gluons emitted by valence quarks
22525 VALPRO = 1.D0
22526 IF(II.EQ.1) VALPRO = VALPRG(1)
22527 IVQ1 = 1
22528 IVG1 = 0
22529 IVAL1 = MAX(IVAL1,0)
22530 IF(IVAL1.EQ.0) THEN
22531 IVQ1 = 0
22532 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22533 IVAL1 = -IVGLU1
22534 IVG1 = 1
22535 ENDIF
22536 ENDIF
22537 VALPRO = 1.D0
22538 IF(II.EQ.1) VALPRO = VALPRG(2)
22539 IVQ2 = 1
22540 IVG2 = 0
22541 IVAL2 = MAX(IVAL2,0)
22542 IF(IVAL2.EQ.0) THEN
22543 IVQ2 = 0
22544 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22545 IVAL2 = -IVGLU2
22546 IVG2 = 1
22547 ENDIF
22548 ENDIF
22549 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22550C debug output
22551 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22552 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22553 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22554
22555C select soft X values
22556 25 CONTINUE
22557C number of soft/remnant quarks
22558 IF(MSPOM.EQ.0) THEN
22559 IF(IPAMDL(18).EQ.0) THEN
22560 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22561 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22562 ELSE
22563 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22564 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22565 ENDIF
22566 ELSE
22567 IF(IPAMDL(18).EQ.0) THEN
22568 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22569 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22570 ELSE
22571 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22572 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22573 ENDIF
22574 ENDIF
22575C debug output
22576 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22577 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22578 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22579
22580 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22581 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22582 I1 = IVQ1
22583 I2 = IVQ2
22584 IF(IVAL1.LE.0) I1 = 0
22585 IF(IVAL2.LE.0) I2 = 0
22586 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22587 MSDIFF = 2*MSPOM
22588 ELSE
22589 MSDIFF = 2*MAX(0,MSPOM-1)
22590 ENDIF
22591 MSG1 = MSPAR1
22592 MSG2 = MSPAR2
22593 MSM1 = MSPAR1-MSDIFF
22594 MSM2 = MSPAR2-MSDIFF
22595 XMAXH1 = MIN(XMAX1,PARMDL(44))
22596 XMAXH2 = MIN(XMAX2,PARMDL(44))
22597 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22598 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22599
22600C correct for proper simulation of high pt tail
22601 IF(IREJ.NE.0) THEN
22602 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22603 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22604 & MSPOM,MHPOM,I1,I2
22605 IF(MSPOM*MHPOM.GT.0) THEN
22606 MSPOM = MSPOM-1
22607 GOTO 25
22608 ELSE IF(MSPOM.GT.1) THEN
22609 MSPOM = MSPOM-1
22610 GOTO 25
22611 ELSE IF(MHPOM.GT.1) THEN
22612 IHARD = IHARD-1
22613 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22614 & .AND.(IPROCE.EQ.1)) THEN
22615 XSS1 = MAX(0.D0,1.D0-XPSUB)
22616 XSS2 = MAX(0.D0,1.D0-XTSUB)
22617 ELSE
22618 XSS1 = 0.D0
22619 XSS2 = 0.D0
22620 ENDIF
22621 DO 103 K=1,IHARD
22622 I = LSIDX(K)
22623 XSS1 = XSS1+ XHD(I,1)
22624 XSS2 = XSS2+ XHD(I,2)
22625 103 CONTINUE
22626 GOTO 199
22627 ENDIF
22628 IREJ = 4
22629 GOTO 450
22630 ENDIF
22631C accepted
22632 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22633 MSPAR1 = MSG1
22634 MSPAR2 = MSG2
22635C ------------ kinematics sampled ---------------
22636C debug output
22637 IF(IDEB(24).GE.10) THEN
22638 WRITE(LO,'(1X,A,I3)')
22639 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22640 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22641 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22642 104 CONTINUE
22643 ENDIF
22644 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22645
22646C end of loop
22647 XS1(1) = 1.D0 - XSS1
22648 XS2(1) = 1.D0 - XSS2
22649
22650C process counting
22651 DO 30 N=1,LSCAHD
22652 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22653 30 CONTINUE
22654
22655C soft particle momenta
22656 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22657 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22658 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22659 IREJ = 1
22660 RETURN
22661 ENDIF
22662 DO 55 I=1,MSPAR1
22663 PSOFT1(1,I) = 0.D0
22664 PSOFT1(2,I) = 0.D0
22665 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22666 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22667 55 CONTINUE
22668 DO 60 I=1,MSPAR2
22669 PSOFT2(1,I) = 0.D0
22670 PSOFT2(2,I) = 0.D0
22671 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22672 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22673 60 CONTINUE
22674
22675 KSOFT = MAX(MSPAR1,MSPAR2)
22676 KHARD = MAX(MHPAR1,MHPAR2)
22677 KSPOM = MSPOM
22678 KSREG = MSREG
22679 KHPOM = MHPOM
22680
22681C debug output
22682 IF(IDEB(24).GE.10) THEN
22683 WRITE(LO,'(/1X,A,2I3,2I5)')
22684 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22685 & IVAL1,IVAL2,ITRY,NTRY
22686 IF(MSPAR1+MSPAR2.GT.0) THEN
22687 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22688 XTMP1 = 0.D0
22689 XTMP2 = 0.D0
22690 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22691 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22692 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22693 XTMP1 = XTMP1+XS1(I)
22694 XTMP2 = XTMP2+XS2(I)
22695 ELSE IF(I.LE.MSPAR1) THEN
22696 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22697 XTMP1 = XTMP1+XS1(I)
22698 ELSE IF(I.LE.MSPAR2) THEN
22699 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22700 XTMP2 = XTMP2+XS2(I)
22701 ENDIF
22702 105 CONTINUE
22703 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22704 ENDIF
22705 IF(MHPAR1.GT.0) THEN
22706 WRITE(LO,'(5X,A)')
22707 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22708 DO 107 K=1,MHPAR1
22709 I = LSIDX(K)
22710 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22711 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22712 & NINHD(I,1),NINHD(I,2)
22713 XTMP1 = XTMP1+XHD(I,1)
22714 XTMP2 = XTMP2+XHD(I,2)
22715 107 CONTINUE
22716 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22717 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22718 DO 108 K=1,MHPAR1
22719 I = LSIDX(K)
22720 I3 = 8*I-4
22721 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22722 & NOUTHD(I,1)
22723 108 CONTINUE
22724 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22725 DO 110 K=1,MHPAR2
22726 I = LSIDX(K)
22727 I3 = 8*I-4
22728 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22729 & NOUTHD(I,2)
22730 110 CONTINUE
22731 ENDIF
22732 ENDIF
22733 RETURN
22734
22735C event rejected, print debug information
22736 450 CONTINUE
22737 IFAIL(4) = IFAIL(4)+1
22738 IF(IDEB(24).GE.2) THEN
22739 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22740 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22741 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22742 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22743 IF(IDEB(24).GE.5) THEN
22744 CALL PHO_PREVNT(0)
22745 ELSE
22746 CALL PHO_PREVNT(-1)
22747 ENDIF
22748 ENDIF
22749
22750 END
22751
22752*$ CREATE PHO_HARX12.FOR
22753*COPY PHO_HARX12
22754CDECK ID>, PHO_HARX12
22755 SUBROUTINE PHO_HARX12
22756C**********************************************************************
22757C
22758C selection of x1 and x2 according to 1/x1*1/x2
22759C
22760C**********************************************************************
22761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22762 SAVE
22763
22764 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22765
22766C input/output channels
22767 INTEGER LI,LO
22768 COMMON /POINOU/ LI,LO
22769C data on most recent hard scattering
22770 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22771 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22772 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22773 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22774 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22775 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22776 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22777 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22778 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22779
2278010 CONTINUE
22781 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22782 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22783 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22784 X1 = EXP(Z1)
22785 X2 = EXP(Z2)
22786 AXX = AH/(X1*X2)
22787 W = SQRT(MAX(TINY,1.D0-AXX))
22788 W1 = AXX/(1.D0+W)
22789
22790 END
22791
22792*$ CREATE PHO_HARDX1.FOR
22793*COPY PHO_HARDX1
22794CDECK ID>, PHO_HARDX1
22795 SUBROUTINE PHO_HARDX1
22796C**********************************************************************
22797C
22798C selection of x1 according to 1/x1
22799C ( x2 = 1 )
22800C
22801C**********************************************************************
22802 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22803 SAVE
22804
22805 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22806
22807C input/output channels
22808 INTEGER LI,LO
22809 COMMON /POINOU/ LI,LO
22810C data on most recent hard scattering
22811 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22812 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22813 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22814 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22815 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22816 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22817 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22818 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22819 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22820
22821 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22822 X2 = 1.D0
22823 X1 = EXP(Z1)
22824 AXX = AH/X1
22825 W = SQRT(MAX(TINY,1.D0-AXX))
22826 W1 = AXX/(1.D0+W)
22827
22828 END
22829
22830*$ CREATE PHO_HARKIN.FOR
22831*COPY PHO_HARKIN
22832CDECK ID>, PHO_HARKIN
22833 SUBROUTINE PHO_HARKIN(IREJ)
22834C***********************************************************************
22835C
22836C selection of kinematic variables
22837C (resolved and direct processes)
22838C
22839C***********************************************************************
22840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22841 SAVE
22842
22843 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22844
22845C input/output channels
22846 INTEGER LI,LO
22847 COMMON /POINOU/ LI,LO
22848C event debugging information
22849 INTEGER NMAXD
22850 PARAMETER (NMAXD=100)
22851 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22852 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22853 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22854 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22855C data of c.m. system of Pomeron / Reggeon exchange
22856 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22857 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22858 & SIDP,CODP,SIFP,COFP
22859 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22860 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22861 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22862C data on most recent hard scattering
22863 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22864 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22865 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22866 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22867 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22868 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22869 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22870 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22871 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22872C internal cross check information on hard scattering limits
22873 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22874 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22875
22876 PARAMETER ( Max_pro_2 = 16 )
22877 DIMENSION RM(-1:Max_pro_2)
22878 DATA RM / 3.31D0, 0.0D0,
22879 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22880 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
22881 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
22882 & 1.0D0 /
22883
22884 IREJ = 0
22885 M = MSPR
22886
22887C------------- resolved processes -----------
22888 IF ( M.EQ.1 ) THEN
2288910 CALL PHO_HARX12
22890 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22891 U =-1.D0-V
22892 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22893 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22894 & 'PHO_HARKIN:weight error',M
22895 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22896 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22897 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
2289820 CALL PHO_HARX12
22899 WL = LOG(W1)
22900 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22901 U =-1.D0-V
22902 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22903 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22904 & 'PHO_HARKIN:weight error',M
22905 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22906 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22907 ELSEIF ( M.EQ.3 ) THEN
2290830 CALL PHO_HARX12
22909 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22910 U =-1.D0-V
22911 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22912 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22913 & 'PHO_HARKIN:weight error',M
22914 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22915 ELSEIF ( M.EQ.5 ) THEN
2291650 CALL PHO_HARX12
22917 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22918 U =-1.D0-V
22919 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22920 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22921 & 'PHO_HARKIN:weight error',M
22922 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22923 ELSEIF ( M.EQ.6 ) THEN
2292460 CALL PHO_HARX12
22925 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22926 U =-1.D0-V
22927 R = (4.D0/9.D0)*(U*U+V*V)*AXX
22928 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22929 & 'PHO_HARKIN:weight error',M
22930 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22931 ELSEIF ( M.EQ.7 ) THEN
2293270 CALL PHO_HARX12
22933 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22934 U =-1.D0-V
22935 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22936 & -(4.D0/27.D0)*V/U)
22937 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22938 & 'PHO_HARKIN:weight error',M
22939 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22940 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22941 ELSEIF ( M.EQ.8 ) THEN
2294280 CALL PHO_HARX12
22943 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22944 U =-1.D0-V
22945 R = (4.D0/9.D0)*(1.D0+U*U)
22946 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22947 & 'PHO_HARKIN:weight error',M
22948 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22949 ELSEIF ( M.EQ.-1 ) THEN
2295090 CALL PHO_HARX12
22951 WL = LOG(W1)
22952 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22953 U =-1.D0-V
22954 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22955 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22956 & 'PHO_HARKIN:weight error',M
22957 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22958C------------- direct / single-resolved processes -----------
22959 ELSEIF ( M.EQ.10 ) THEN
22960100 CALL PHO_HARDX1
22961 WL = LOG(AXX/(1.D0+W)**2)
22962 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22963 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22964 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22965 & 'PHO_HARKIN:weight error',M
22966 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22967 V =-1.D0-U
22968 X2 = X1
22969 X1 = 1.D0
22970 ELSEIF ( M.EQ.11) THEN
22971110 CALL PHO_HARDX1
22972 WL = LOG(W1)
22973 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22974 V =-1.D0-U
22975 R = (U*U+V*V)/V*WL*AXX
22976 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22977 & 'PHO_HARKIN:weight error',M
22978 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22979 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22980 X2 = X1
22981 X1 = 1.D0
22982 ELSEIF ( M.EQ.12 ) THEN
22983120 CALL PHO_HARDX1
22984 WL = LOG(AXX/(1.D0+W)**2)
22985 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22986 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22987 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22988 & 'PHO_HARKIN:weight error',M
22989 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22990 ELSEIF ( M.EQ.13) THEN
22991130 CALL PHO_HARDX1
22992 WL = LOG(W1)
22993 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22994 U =-1.D0-V
22995 R = (U*U+V*V)/U*WL*AXX
22996 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22997 & 'PHO_HARKIN:weight error',M
22998 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22999 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23000C------------- (double) direct process -----------
23001 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23002 X1 = 1.D0
23003 X2 = 1.D0
23004 AXX= AH
23005 W = SQRT(MAX(TINY,1.D0-AXX))
23006 W1 = AXX/(1.D0+W)
23007 WL = LOG(W1)
23008 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23009 U =-1.D0-V
23010 R = -(U*U+V*V)/U
23011 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23012 & 'PHO_HARKIN:weight error',M
23013 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23014 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23015C---------------------------------------------
23016 ELSE
23017 WRITE(LO,'(/1X,A,I3)')
23018 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23019 CALL PHO_ABORT
23020 ENDIF
23021
23022 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23023 U = -1.D0-V
23024 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23025 PT = SQRT(U*V*X1*X2)*ECMP
23026 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23027 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23028
23029***************************************************************
23030 MM = M
23031 IF(M.EQ.-1) MM = 3
23032 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23033 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23034 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23035 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23036 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23037 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23038 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23039 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23040***************************************************************
23041
23042 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23043 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23044
23045 END
23046
23047*$ CREATE PHO_HARWGH.FOR
23048*COPY PHO_HARWGH
23049CDECK ID>, PHO_HARWGH
23050 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23051C***********************************************************************
23052C
23053C calculate product of PDFs and coupling constants
23054C according to selected MSPR (process type)
23055C
23056C input: /POCKIN/
23057C
23058C output: PDS resulting from PDFs alone
23059C FDISTR complete weight function
23060C PDA,PDB fields containing the PDFs
23061C
23062C***********************************************************************
23063 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23064 SAVE
23065
23066 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23067
23068C input/output channels
23069 INTEGER LI,LO
23070 COMMON /POINOU/ LI,LO
23071C event debugging information
23072 INTEGER NMAXD
23073 PARAMETER (NMAXD=100)
23074 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23075 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23076 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23077 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23078C model switches and parameters
23079 CHARACTER*8 MDLNA
23080 INTEGER ISWMDL,IPAMDL
23081 DOUBLE PRECISION PARMDL
23082 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23083C data of c.m. system of Pomeron / Reggeon exchange
23084 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23085 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23086 & SIDP,CODP,SIFP,COFP
23087 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23088 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23089 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23090C currently activated parton density parametrizations
23091 CHARACTER*8 PDFNAM
23092 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23093 DOUBLE PRECISION PDFLAM,PDFQ2M
23094 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23095 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23096C hard scattering parameters used for most recent hard interaction
23097 INTEGER NFbeta,NF
23098 DOUBLE PRECISION ALQCD2,BQCD
23099 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23100C some hadron information, will be deleted in future versions
23101 INTEGER NFS
23102 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23103 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23104C scale parameters for parton model calculations
23105 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23106 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23107 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23108 & NQQAL,NQQALI,NQQALF,NQQPD
23109C data on most recent hard scattering
23110 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23111 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23112 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23113 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23114 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23115 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23116 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23117 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23118 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23119C hard cross sections and MC selection weights
23120 INTEGER Max_pro_2
23121 PARAMETER ( Max_pro_2 = 16 )
23122 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23123 & MH_acc_1,MH_acc_2
23124 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23125 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23126 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23127 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23128 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23129 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23130C some constants
23131 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23132 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23133 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23134
23135 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23136 DIMENSION PDA(-6:6),PDB(-6:6)
23137
23138 FDISTR = 0.D0
23139C set hard scale QQ for alpha and partondistr.
23140 IF ( NQQAL.EQ.1 ) THEN
23141 QQAL = AQQAL*PT*PT
23142 ELSEIF ( NQQAL.EQ.2 ) THEN
23143 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23144 ELSEIF ( NQQAL.EQ.3 ) THEN
23145 QQAL = AQQAL*X1*X2*ECMP*ECMP
23146 ELSEIF ( NQQAL.EQ.4 ) THEN
23147 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23148 ENDIF
23149 IF ( NQQPD.EQ.1 ) THEN
23150 QQPD = AQQPD*PT*PT
23151 ELSEIF ( NQQPD.EQ.2 ) THEN
23152 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23153 ELSEIF ( NQQPD.EQ.3 ) THEN
23154 QQPD = AQQPD*X1*X2*ECMP*ECMP
23155 ELSEIF ( NQQPD.EQ.4 ) THEN
23156 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23157 ENDIF
23158C coupling constants, PDFs
23159 IF(MSPR.LT.9) THEN
23160 ALPHA1 = PHO_ALPHAS(QQAL,3)
23161 ALPHA2 = ALPHA1
23162 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23163 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23164 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23165 PDS = PDA(0)*PDB(0)
23166 ELSE
23167 S2 = 0.D0
23168 S3 = 0.D0
23169 S4 = 0.D0
23170 S5 = 0.D0
23171 DO 10 I=1,NF
23172 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23173 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23174 S4 = S4+PDA(I)+PDA(-I)
23175 S5 = S5+PDB(I)+PDB(-I)
23176 10 CONTINUE
23177 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23178 PDS = S2
23179 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23180 PDS = PDA(0)*S5+PDB(0)*S4
23181 ELSE IF(MSPR.EQ.7) THEN
23182 PDS = S3
23183 ELSE IF(MSPR.EQ.8) THEN
23184 PDS = S4*S5-(S2+S3)
23185 ENDIF
23186 ENDIF
23187 ELSE IF(MSPR.LT.12) THEN
23188 ALPHA2 = PHO_ALPHAS(QQAL,2)
23189 IF(IDPDG1.EQ.22) THEN
23190 ALPHA1 = pho_alphae(QQAL)
23191 ELSE IF(IDPDG1.EQ.990) THEN
23192 ALPHA1 = PARMDL(74)
23193 ENDIF
23194 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23195 S4 = 0.D0
23196 S6 = 0.D0
23197 DO 15 I=1,NF
23198 S4 = S4+PDB(I)+PDB(-I)
23199C charge counting
23200* IF(MOD(I,2).EQ.0) THEN
23201* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23202* ELSE
23203* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23204* ENDIF
23205 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23206 15 CONTINUE
23207 IF(MSPR.EQ.10) THEN
23208 IF(IDPDG1.EQ.990) THEN
23209 PDS = S4
23210 ELSE
23211 PDS = S6
23212 ENDIF
23213 ELSE
23214 PDS = PDB(0)
23215 ENDIF
23216 ELSE IF(MSPR.LT.14) THEN
23217 ALPHA1 = PHO_ALPHAS(QQAL,1)
23218 IF(IDPDG2.EQ.22) THEN
23219 ALPHA2 = pho_alphae(QQAL)
23220 ELSE IF(IDPDG2.EQ.990) THEN
23221 ALPHA2 = PARMDL(74)
23222 ENDIF
23223 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23224 S4 = 0.D0
23225 S6 = 0.D0
23226 DO 20 I=1,NF
23227 S4 = S4+PDA(I)+PDA(-I)
23228C charge counting
23229* IF(MOD(I,2).EQ.0) THEN
23230* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23231* ELSE
23232* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23233* ENDIF
23234 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23235 20 CONTINUE
23236 IF(MSPR.EQ.12) THEN
23237 IF(IDPDG2.EQ.990) THEN
23238 PDS = S4
23239 ELSE
23240 PDS = S6
23241 ENDIF
23242 ELSE
23243 PDS = PDA(0)
23244 ENDIF
23245 ELSE IF(MSPR.EQ.14) THEN
23246 SSR = X1*X2*ECMP*ECMP
23247 IF(IDPDG1.EQ.22) THEN
23248 ALPHA1 = pho_alphae(SSR)
23249 ELSE IF(IDPDG1.EQ.990) THEN
23250 ALPHA1 = PARMDL(74)
23251 ENDIF
23252 IF(IDPDG2.EQ.22) THEN
23253 ALPHA2 = pho_alphae(SSR)
23254 ELSE IF(IDPDG2.EQ.990) THEN
23255 ALPHA2 = PARMDL(74)
23256 ENDIF
23257 PDS = 1.D0
23258 ELSE
23259 WRITE(LO,'(/1X,A,I4)')
23260 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23261 CALL PHO_ABORT
23262 ENDIF
23263
23264C complete weight
23265 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23266
23267C debug output
23268 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23269 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23270 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23271
23272 END
23273
23274*$ CREATE PHO_HARSCA.FOR
23275*COPY PHO_HARSCA
23276CDECK ID>, PHO_HARSCA
23277 SUBROUTINE PHO_HARSCA(IMODE,IP)
23278C***********************************************************************
23279C
23280C PHO_HARSCA determines the type of hard subprocess, the partons
23281C taking part in this subprocess and the kinematic variables
23282C
23283C input: IMODE 1 direct processes
23284C 2 resolved processes
23285C -1 initialization
23286C -2 output of statistics
23287C IP 1-4 particle combination (hadron/photon)
23288C
23289C***********************************************************************
23290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23291 SAVE
23292
23293 PARAMETER( EPS = 1.D-10,
23294 & DEPS = 1.D-30 )
23295
23296C input/output channels
23297 INTEGER LI,LO
23298 COMMON /POINOU/ LI,LO
23299C event debugging information
23300 INTEGER NMAXD
23301 PARAMETER (NMAXD=100)
23302 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23303 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23304 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23305 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23306C model switches and parameters
23307 CHARACTER*8 MDLNA
23308 INTEGER ISWMDL,IPAMDL
23309 DOUBLE PRECISION PARMDL
23310 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23311C internal rejection counters
23312 INTEGER NMXJ
23313 PARAMETER (NMXJ=60)
23314 CHARACTER*10 REJTIT
23315 INTEGER IFAIL
23316 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23317C hard scattering parameters used for most recent hard interaction
23318 INTEGER NFbeta,NF
23319 DOUBLE PRECISION ALQCD2,BQCD
23320 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23321C data of c.m. system of Pomeron / Reggeon exchange
23322 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23323 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23324 & SIDP,CODP,SIFP,COFP
23325 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23326 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23327 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23328C names of hard scattering processes
23329 INTEGER Max_pro_1
23330 PARAMETER ( Max_pro_1 = 16 )
23331 CHARACTER*18 PROC
23332 COMMON /POHPRO/ PROC(0:Max_pro_1)
23333C data on most recent hard scattering
23334 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23335 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23336 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23337 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23338 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23339 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23340 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23341 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23342 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23343C hard scattering data
23344 INTEGER MSCAHD
23345 PARAMETER ( MSCAHD = 50 )
23346 INTEGER LSCAHD,LSC1HD,LSIDX,
23347 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23348 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23349 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23350 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23351 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23352 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23353 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23354 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23355 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23356C hard cross sections and MC selection weights
23357 INTEGER Max_pro_2
23358 PARAMETER ( Max_pro_2 = 16 )
23359 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23360 & MH_acc_1,MH_acc_2
23361 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23362 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23363 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23364 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23365 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23366 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23367C cross sections
23368 INTEGER IPFIL,IFAFIL,IFBFIL
23369 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23370 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23371 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23372 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23373 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23374 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23375 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23376 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23377 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23378 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23379 & IPFIL,IFAFIL,IFBFIL
23380C some constants
23381 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23382 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23383 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23384
23385 111 CONTINUE
23386
23387C resolved processes
23388 IF(IMODE.EQ.2) THEN
23389
23390 MH_pro_on(0,IP) = 0
23391 HWgx(9) = 0.D0
23392 DO 15 M=-1,8
23393 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23394 15 CONTINUE
23395 IF(HWgx(9).LT.DEPS) THEN
23396 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23397 & 'no resolved process possible for IP',IP,HWgx(9)
23398 CALL PHO_ABORT
23399 ENDIF
23400C
23401C ----------------------------------------------I
23402C begin of iteration loop (resolved processes) I
23403C I
23404 IREJSC = 0
23405 10 CONTINUE
23406 IREJSC = IREJSC+1
23407 IF(IREJSC.GT.1000) THEN
23408 WRITE(LO,'(/1X,A,I10)')
23409 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23410 CALL PHO_ABORT
23411 ENDIF
23412
23413C find subprocess
23414 B = DT_RNDM(X1)*HWgx(9)
23415 MSPR =-2
23416 SUM = 0.D0
23417 20 MSPR = MSPR+1
23418 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23419 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23420
23421 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23422 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23423
23424C find kin. variables X1,X2 and V
23425 CALL PHO_HARKIN(IREJ)
23426 IF(IREJ.NE.0) THEN
23427 IFAIL(29) = IFAIL(29)+1
23428 GOTO 10
23429 ENDIF
23430C calculate remaining distribution
23431 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23432C actualize counter for cross-section calculation
23433 if(F.LE.1.D-15) then
23434 F = 0.D0
23435 goto 10
23436 endif
23437* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23438* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23439 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23440C check F against FMAX
23441 WEIGHT = F/(HWgx(MSPR)+DEPS)
23442 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23443C-------------------------------------------------------------------
23444 IF(WEIGHT.GT.1.D0) THEN
23445 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23446 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23447 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23448 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23449 & ECMP,PTWANT,AS,AH,PT
23450 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23451 & ETAC,ETAD,X1,X2,V
23452 CALL PHO_PREVNT(-1)
23453 ENDIF
23454C-------------------------------------------------------------------
23455C I
23456C end of iteration loop (resolved processes) I
23457C --------------------------------------------I
23458C
23459C*********************************************************************
23460C
23461C direct processes
23462
23463 ELSE IF(IMODE.EQ.1) THEN
23464
23465C single-resolved processes kinematically forbidden
23466 if(Z1DIF.lt.0.D0) then
23467 HWgx(10) = 0.D0
23468 HWgx(11) = 0.D0
23469 HWgx(12) = 0.D0
23470 HWgx(13) = 0.D0
23471 endif
23472
23473 HWgx(15) = 0.D0
23474 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23475 DO M= 10,14
23476 IF(MH_pro_on(M,IP).EQ.1) then
23477 if((M.eq.10).or.(M.eq.11)) then
23478 fac = FSUH(1)*FSUP(2)
23479 else if((M.eq.12).or.(M.eq.13)) then
23480 fac = FSUP(1)*FSUH(2)
23481 else
23482 fac = FSUH(1)*FSUH(2)
23483 endif
23484 HWgx(15) = HWgx(15)+HWgx(M)*fac
23485 endif
23486 ENDDO
23487 else
23488 DO M= 10,14
23489 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23490 ENDDO
23491 endif
23492 IF(HWgx(15).LT.DEPS) THEN
23493 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23494 & 'no direct/single-resolved process possible (IP)',IP
23495 CALL PHO_ABORT
23496 ENDIF
23497C
23498C ----------------------------------------------I
23499C begin of iteration loop (direct processes) I
23500C I
23501 IREJSC = 0
23502 100 CONTINUE
23503 IREJSC = IREJSC+1
23504 IF(IREJSC.GT.1000) THEN
23505 WRITE(LO,'(/1X,A,I10)')
23506 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23507 CALL PHO_ABORT
23508 ENDIF
23509
23510C find subprocess
23511 B = DT_RNDM(X1)*HWgx(15)
23512 MSPR = 9
23513 SUM = 0.D0
23514 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23515 150 continue
23516 MSPR = MSPR+1
23517 IF(MH_pro_on(MSPR,IP).EQ.1) then
23518 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23519 fac = FSUH(1)*FSUP(2)
23520 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23521 fac = FSUP(1)*FSUH(2)
23522 else
23523 fac = FSUH(1)*FSUH(2)
23524 endif
23525 SUM = SUM+HWgx(MSPR)*fac
23526 endif
23527 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23528 else
23529 200 continue
23530 MSPR = MSPR+1
23531 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23532 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23533 endif
23534
23535 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23536 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23537
23538C find kin. variables X1,X2 and V
23539 CALL PHO_HARKIN(IREJ)
23540 IF(IREJ.NE.0) THEN
23541 IFAIL(28) = IFAIL(28)+1
23542 GOTO 100
23543 ENDIF
23544
23545C calculate remaining distribution
23546 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23547
23548C counter for cross-section calculation
23549 if(F.LE.1.D-15) then
23550 F=0.D0
23551 goto 100
23552 endif
23553* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23554* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23555 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23556C check F against FMAX
23557 WEIGHT = F/(HWgx(MSPR)+DEPS)
23558 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23559C-------------------------------------------------------------------
23560 IF(WEIGHT.GT.1.D0) THEN
23561 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23562 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23563 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23564 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23565 & ECMP,PTWANT,AS,AH,PT
23566 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23567 & ETAC,ETAD,X1,X2,V
23568 CALL PHO_PREVNT(-1)
23569 ENDIF
23570C-------------------------------------------------------------------
23571C I
23572C end of iteration loop (direct processes) I
23573C --------------------------------------------I
23574
23575 ELSE IF(IMODE.EQ.-1) THEN
23576
23577C initialize cross section calculations
23578
23579 DO 40 M=-1,Max_pro_2
23580* DO 30 I=5,6
23581* XSECT(I,M) = 0.D0
23582*30 CONTINUE
23583C reset counters
23584 DO 35 J=1,4
23585 MH_tried(M,J) = 0
23586 MH_acc_1(M,J) = 0
23587 MH_acc_2(M,J) = 0
23588 35 CONTINUE
23589 40 CONTINUE
23590 IF(IDEB(78).GE.0) THEN
23591 WRITE(LO,'(/1X,A,/1X,A)')
23592 & 'PHO_HARSCA: activated hard processes',
23593 & '------------------------------------'
23594 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23595 DO 42 M=1,Max_pro_2
23596 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23597 & (MH_pro_on(M,J),J=1,4)
23598 42 CONTINUE
23599 ENDIF
23600 RETURN
23601
23602 ELSE IF(IMODE.EQ.-2) THEN
23603
23604C calculation of process statistics
23605
23606 do K=1,4
23607
23608 MH_tried(0,K) = 0
23609 MH_acc_1(0,K) = 0
23610 MH_acc_2(0,K) = 0
23611 MH_tried(9,K) = 0
23612 MH_acc_1(9,K) = 0
23613 MH_acc_2(9,K) = 0
23614 MH_tried(15,K) = 0
23615 MH_acc_1(15,K) = 0
23616 MH_acc_2(15,K) = 0
23617
23618 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23619 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23620 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23621
23622 do M=1,8
23623 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23624 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23625 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23626 enddo
23627 do M=10,14
23628 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23629 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23630 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23631 enddo
23632 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23633 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23634 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23635 enddo
23636
23637 IF(IDEB(78).GE.1) THEN
23638 WRITE(LO,'(/1X,A,/1X,A)')
23639 & 'PHO_HARSCA: internal rejection statistics',
23640 & '-----------------------------------------'
23641 do K=1,4
23642 IF(MH_tried(0,K).GT.0) THEN
23643 WRITE(LO,'(5X,A,I3)')
23644 & 'process (sampled/accepted) for IP:',K
23645 do M=0,Max_pro_2
23646 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23647 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23648 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23649 enddo
23650 ENDIF
23651 enddo
23652 ENDIF
23653 RETURN
23654
23655 ELSE
23656 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23657 & 'unsupported mode',IMODE
23658 CALL PHO_ABORT
23659 ENDIF
23660
23661C the event is accepted now
23662C actualize counter for accepted events
23663 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23664 IF(MSPR.EQ.-1) MSPR = 3
23665C
23666C find flavor of initial partons
23667C
23668 SUM = 0.D0
23669 SCHECK = DT_RNDM(SUM)*PDS-EPS
23670 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23671 IA = 0
23672 IB = 0
23673 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23674 DO 610 IA=-NF,NF
23675 IF ( IA.EQ.0 ) GOTO 610
23676 SUM = SUM+PDF1(IA)*PDF2(-IA)
23677 IF ( SUM.GE.SCHECK ) GOTO 620
23678 610 CONTINUE
23679 620 IB =-IA
23680 ELSEIF ( MSPR.EQ.3 ) THEN
23681 IB = 0
23682 DO 630 IA=-NF,NF
23683 IF ( IA.EQ.0 ) GOTO 630
23684 SUM = SUM+PDF1(0)*PDF2(IA)
23685 IF ( SUM.GE.SCHECK ) GOTO 640
23686 SUM = SUM+PDF1(IA)*PDF2(0)
23687 IF ( SUM.GE.SCHECK ) GOTO 650
23688 630 CONTINUE
23689 640 IB = IA
23690 IA = 0
23691 650 CONTINUE
23692 ELSEIF ( MSPR.EQ.7 ) THEN
23693 DO 660 IA=-NF,NF
23694 IF ( IA.EQ.0 ) GOTO 660
23695 SUM = SUM+PDF1(IA)*PDF2(IA)
23696 IF ( SUM.GE.SCHECK ) GOTO 670
23697 660 CONTINUE
23698 670 IB = IA
23699 ELSEIF ( MSPR.EQ.8 ) THEN
23700 DO 690 IA=-NF,NF
23701 IF ( IA.EQ.0 ) GOTO 690
23702 DO 680 IB=-NF,NF
23703 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23704 SUM = SUM+PDF1(IA)*PDF2(IB)
23705 IF ( SUM.GE.SCHECK ) GOTO 700
23706 680 CONTINUE
23707 690 CONTINUE
23708 700 CONTINUE
23709 ELSEIF ( MSPR.EQ.10 ) THEN
23710 IA = 0
23711 DO 710 IB=-NF,NF
23712 IF ( IB.NE.0 ) THEN
23713 IF(IDPDG1.EQ.22) THEN
23714* IF(MOD(ABS(IB),2).EQ.0) THEN
23715* SUM = SUM+PDF2(IB)*4.D0/9.D0
23716* ELSE
23717* SUM = SUM+PDF2(IB)*1.D0/9.D0
23718* ENDIF
23719 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23720 ELSE
23721 SUM = SUM+PDF2(IB)
23722 ENDIF
23723 IF ( SUM.GE.SCHECK ) GOTO 720
23724 ENDIF
23725 710 CONTINUE
23726 720 CONTINUE
23727 ELSEIF ( MSPR.EQ.12 ) THEN
23728 IB = 0
23729 DO 810 IA=-NF,NF
23730 IF ( IA.NE.0 ) THEN
23731 IF(IDPDG2.EQ.22) THEN
23732* IF(MOD(ABS(IA),2).EQ.0) THEN
23733* SUM = SUM+PDF1(IA)*4.D0/9.D0
23734* ELSE
23735* SUM = SUM+PDF1(IA)*1.D0/9.D0
23736* ENDIF
23737 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23738 ELSE
23739 SUM = SUM+PDF1(IA)
23740 ENDIF
23741 IF ( SUM.GE.SCHECK ) GOTO 820
23742 ENDIF
23743 810 CONTINUE
23744 820 CONTINUE
23745 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23746 IA = 0
23747 IB = 0
23748 ENDIF
23749C final check
23750 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
ecf67adb 23751 WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23752 WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
9aaba0d6 23753 GOTO 111
23754 ENDIF
23755C
23756C find flavour of final partons
23757C
23758 IC = IA
23759 ID = IB
23760 IF ( MSPR.EQ.2 ) THEN
23761 IC = 0
23762 ID = 0
23763 ELSEIF ( MSPR.EQ.4 ) THEN
23764 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23765 IF ( IC.GT.NF ) IC = NF-IC
23766 ID =-IC
23767 ELSEIF ( MSPR.EQ.6 ) THEN
23768 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23769 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23770 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23771 ID =-IC
23772 ELSEIF ( MSPR.EQ.11) THEN
23773 SUM = 0.D0
23774 DO 730 IC=-NF,NF
23775 IF ( IC.NE.0 ) THEN
23776 IF(IDPDG1.EQ.22) THEN
23777* IF(MOD(ABS(IC),2).EQ.0) THEN
23778* SUM = SUM + 4.D0
23779* ELSE
23780* SUM = SUM + 1.D0
23781* ENDIF
23782 SUM = SUM + Q_ch2(IC)
23783 ELSE
23784 SUM = SUM + 1.D0
23785 ENDIF
23786 ENDIF
23787 730 CONTINUE
23788 SCHECK = DT_RNDM(SUM)*SUM-EPS
23789 SUM = 0.D0
23790 DO 740 IC=-NF,NF
23791 IF ( IC.NE.0 ) THEN
23792 IF(IDPDG1.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 IF ( SUM.GE.SCHECK ) GOTO 750
23803 ENDIF
23804 740 CONTINUE
23805 750 CONTINUE
23806 ID = -IC
23807 ELSEIF ( MSPR.EQ.12) THEN
23808 IC = 0
23809 ID = IA
23810 ELSEIF ( MSPR.EQ.13) THEN
23811 SUM = 0.D0
23812 DO 830 IC=-NF,NF
23813 IF ( IC.NE.0 ) THEN
23814 IF(IDPDG2.EQ.22) THEN
23815* IF(MOD(ABS(IC),2).EQ.0) THEN
23816* SUM = SUM + 4.D0
23817* ELSE
23818* SUM = SUM + 1.D0
23819* ENDIF
23820 SUM = SUM + Q_ch2(IC)
23821 ELSE
23822 SUM = SUM + 1.D0
23823 ENDIF
23824 ENDIF
23825 830 CONTINUE
23826 SCHECK = DT_RNDM(SUM)*SUM-EPS
23827 SUM = 0.D0
23828 DO 840 IC=-NF,NF
23829 IF ( IC.NE.0 ) THEN
23830 IF(IDPDG2.EQ.22) THEN
23831* IF(MOD(ABS(IC),2).EQ.0) THEN
23832* SUM = SUM + 4.D0
23833* ELSE
23834* SUM = SUM + 1.D0
23835* ENDIF
23836 SUM = SUM + Q_ch2(IC)
23837 ELSE
23838 SUM = SUM + 1.D0
23839 ENDIF
23840 IF ( SUM.GE.SCHECK ) GOTO 850
23841 ENDIF
23842 840 CONTINUE
23843 850 CONTINUE
23844 ID = -IC
23845 ELSEIF ( MSPR.EQ.14) THEN
23846 SUM = 0.D0
23847 DO 930 IC=1,NF
23848 FAC1 = 1.D0
23849 FAC2 = 1.D0
23850 IF(MOD(ABS(IC),2).EQ.0) THEN
23851 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23852 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23853 ENDIF
23854 SUM = SUM + FAC1*FAC2
23855 930 CONTINUE
23856 IF(IPAMDL(64).NE.0) THEN
23857 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23858 ENDIF
23859 SCHECK = DT_RNDM(SUM)*SUM-EPS
23860 SUM = 0.D0
23861 DO 940 IC=1,NF
23862 FAC1 = 1.D0
23863 FAC2 = 1.D0
23864 IF(MOD(ABS(IC),2).EQ.0) THEN
23865 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23866 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23867 ENDIF
23868 SUM = SUM + FAC1*FAC2
23869 IF ( SUM.GE.SCHECK ) GOTO 950
23870 940 CONTINUE
23871 IC = 15
23872 950 CONTINUE
23873 ID = -IC
23874 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23875 ENDIF
23876 if(IC.eq.0) then
23877 XM3 = 0.D0
23878 else
23879 XM3 = PHO_PMASS(IC,3)
23880 endif
23881 if(ID.eq.0) then
23882 XM4 = 0.D0
23883 else
23884 XM4 = PHO_PMASS(ID,3)
23885 endif
23886 IF(ABS(IC).EQ.15) GOTO 955
23887
23888C valence quarks involved?
23889 IV1 = 0
23890 IF(IA.NE.0) THEN
23891 IF(IDPDG1.EQ.22) THEN
23892 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23893 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23894 ELSE
23895 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23896 ENDIF
23897 ENDIF
23898 IV2 = 0
23899 IF(IB.NE.0) THEN
23900 IF(IDPDG2.EQ.22) THEN
23901 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23902 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23903 ELSE
23904 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23905 ENDIF
23906 ENDIF
23907C
23908C fill event record
23909C
23910 955 CONTINUE
23911 CALL PHO_SFECFE(SINPHI,COSPHI)
23912 ECM2 = ECMP/2.D0
23913C incoming partons
23914 PHI1(1) = 0.D0
23915 PHI1(2) = 0.D0
23916 PHI1(3) = ECM2*X1
23917 PHI1(4) = PHI1(3)
23918 PHI1(5) = 0.D0
23919 PHI2(1) = 0.D0
23920 PHI2(2) = 0.D0
23921 PHI2(3) = -ECM2*X2
23922 PHI2(4) = -PHI2(3)
23923 PHI2(5) = 0.D0
23924C outgoing partons
23925 PHO1(1) = PT*COSPHI
23926 PHO1(2) = PT*SINPHI
23927 PHO1(3) = -ECM2*(U*X1-V*X2)
23928 PHO1(4) = -ECM2*(U*X1+V*X2)
23929 PHO1(5) = XM3
23930 PHO2(1) = -PHO1(1)
23931 PHO2(2) = -PHO1(2)
23932 PHO2(3) = -ECM2*(V*X1-U*X2)
23933 PHO2(4) = -ECM2*(V*X1+U*X2)
23934 PHO2(5) = XM4
23935
23936C convert to mass shell
23937 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23938 IF(IREJ.NE.0) THEN
23939 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23940 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23941 & PT,XM3,XM4
23942 GOTO 111
23943 ENDIF
23944 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23945
23946C debug output
23947 IF(IDEB(78).GE.20) THEN
23948 SHAT = X1*X2*ECMP*ECMP
23949 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23950 & MSPR,IA,IB,IC,ID
23951 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23952 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23953 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23954 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23955 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23956 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23957 ENDIF
23958
23959 END
23960
23961*$ CREATE PHO_HARFAC.FOR
23962*COPY PHO_HARFAC
23963CDECK ID>, PHO_HARFAC
23964 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23965C*********************************************************************
23966C
23967C initialization: find scaling factors and maxima of remaining
23968C weights
23969C
23970C input: PTCUT transverse momentum cutoff
23971C ECMI cms energy
23972C
23973C output: Hfac(-1:Max_pro_2) field for sampling hard processes
23974C
23975C*********************************************************************
23976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23977 SAVE
23978
23979 PARAMETER ( MXABWT = 96 )
23980
23981C input/output channels
23982 INTEGER LI,LO
23983 COMMON /POINOU/ LI,LO
23984C data of c.m. system of Pomeron / Reggeon exchange
23985 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23986 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23987 & SIDP,CODP,SIFP,COFP
23988 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23989 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23990 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23991C some constants
23992 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23993 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23994 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23995C hard scattering parameters used for most recent hard interaction
23996 INTEGER NFbeta,NF
23997 DOUBLE PRECISION ALQCD2,BQCD
23998 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23999C integration precision for hard cross sections (obsolete)
24000 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24001 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24002C data on most recent hard scattering
24003 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24004 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24005 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24006 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24007 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24008 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24009 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24010 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24011 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24012C hard cross sections and MC selection weights
24013 INTEGER Max_pro_2
24014 PARAMETER ( Max_pro_2 = 16 )
24015 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24016 & MH_acc_1,MH_acc_2
24017 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24018 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24019 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24020 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24021 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24022 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24023
24024 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24025 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24026 & F124(-1:Max_pro_2)
24027 DATA F124 / 1.D0,0.D0,
24028 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24029 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24030
24031 SS = ECMI*ECMI
24032 AH = (2.D0*PTCUT/ECMI)**2
24033 ALN = LOG(AH)
24034 HLN = LOG(0.5D0)
24035 NPOINT = NGAUIN
24036 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24037 DO 10 M=-1,Max_pro_2
24038 S1(M) = 0.D0
2403910 CONTINUE
24040
24041C resolved processes
24042 DO 80 I1=1,NPOINT
24043 Z1 = ABSZ(I1)
24044 X1 = EXP(ALN*Z1)
24045 DO 20 M=-1,9
24046 S2(M) = 0.D0
2404720 CONTINUE
24048
24049 DO 60 I2=1,NPOINT
24050 Z2 = (1.D0-Z1)*ABSZ(I2)
24051 X2 = EXP(ALN*Z2)
24052 FAXX = AH/(X1*X2)
24053 W = SQRT(1.D0-FAXX)
24054 W1 = FAXX/(1.+W)
24055 WLOG = LOG(W1)
24056 FWW = FAXX*WLOG/W
24057 DO 30 M=-1,9
24058 S(M) = 0.D0
2405930 CONTINUE
24060
24061 DO 40 I=1,NPOINT
24062 Z = ABSZ(I)
24063 VA =-0.5D0*W1/(W1+Z*W)
24064 UA =-1.D0-VA
24065 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24066 UB =-1.D0-VB
24067 VC =-EXP(HLN+Z*WLOG)
24068 UC =-1.D0-VC
24069 VE =-0.5D0*(1.D0+W)+Z*W
24070 UE =-1.D0-VE
24071 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24072 & WEIG(I)
24073 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24074 & WEIG(I)
24075 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24076 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24077 & (8./27.)*UA*UA*VA)*WEIG(I)
24078 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24079 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24080 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24081 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24082 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
2408340 CONTINUE
24084 S(4) = S(2)*(9./32.)
24085 DO 50 M=-1,8
24086 S2(M) = S2(M)+S(M)*WEIG(I2)*W
2408750 CONTINUE
2408860 CONTINUE
24089 DO 70 M=-1,8
24090 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
2409170 CONTINUE
2409280 CONTINUE
24093 S1(4) = S1(4)*NF
24094 S1(6) = S1(6)*MAX(0,NF-1)
24095C
24096C direct processes
24097 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24098 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24099 DO 180 I1=1,NPOINT
24100 Z2 = ABSZ(I1)
24101 X2 = EXP(ALN*Z2)
24102 FAXX = AH/X2
24103 W = SQRT(1.D0-FAXX)
24104 W1 = FAXX/(1.D0+W)
24105 WLOG = LOG(W1)
24106 WL = LOG(FAXX/(1.D0+W)**2)
24107 FWW1 = FAXX*WL/ALN
24108 FWW2 = FAXX*WLOG/ALN
24109 DO 130 M=10,12
24110 S(M) = 0.D0
24111 130 CONTINUE
24112C
24113 DO 140 I=1,NPOINT
24114 Z = ABSZ(I)
24115 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24116 VA =-1.D0-UA
24117 VB =-EXP(HLN+Z*WLOG)
24118 UB =-1.D0-VB
24119 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24120 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24121 140 CONTINUE
24122 DO 170 M=10,11
24123 S1(M) = S1(M)+S(M)*WEIG(I1)
24124 170 CONTINUE
24125 180 CONTINUE
24126 S1(12) = S1(10)
24127 S1(13) = S1(11)
24128C quark charges fractions
24129 IF(IDPDG1.EQ.22) THEN
24130 CHRNF = 0.D0
24131 DO 100 I=1,NF
24132 CHRNF = CHRNF + Q_ch2(I)
24133 100 CONTINUE
24134 S1(11) = S1(11)*CHRNF
24135 ELSE IF(IDPDG1.EQ.990) THEN
24136 S1(11) = S1(11)*NF
24137 ELSE
24138 S1(11) = 0.D0
24139 ENDIF
24140 IF(IDPDG2.EQ.22) THEN
24141 CHRNF = 0.D0
24142 DO 200 I=1,NF
24143 CHRNF = CHRNF + Q_ch2(I)
24144 200 CONTINUE
24145 S1(13) = S1(13)*CHRNF
24146 ELSE IF(IDPDG2.EQ.990) THEN
24147 S1(13) = S1(13)*NF
24148 ELSE
24149 S1(13) = 0.D0
24150 ENDIF
24151 ENDIF
24152C
24153C global factors
24154 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24155 DO 90 M=-1,Max_pro_2
24156 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
2415790 CONTINUE
24158C
24159C double direct process
24160 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24161 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24162 FAC = 0.D0
24163 DO 300 I=1,NF
24164 IF(IDPDG1.EQ.22) THEN
24165 F1 = Q_ch2(I)
24166 ELSE
24167 F1 = 1.D0
24168 ENDIF
24169 IF(IDPDG2.EQ.22) THEN
24170 F2 = Q_ch2(I)
24171 ELSE
24172 F2 = 1.D0
24173 ENDIF
24174 FAC = FAC+F1*F2*3.D0
24175 300 CONTINUE
24176 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24177 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24178 & *GEV2MB*FAC
24179 ENDIF
24180 END
24181
24182*$ CREATE PHO_HARWGX.FOR
24183*COPY PHO_HARWGX
24184CDECK ID>, PHO_HARWGX
24185 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24186C**********************************************************************
24187C
24188C find maximum of remaining weight for MC sampling
24189C
24190C input: PTCUT transverse momentum cutoff
24191C ECM cms energy
24192C
24193C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24194C
24195C**********************************************************************
24196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24197 SAVE
24198
24199 PARAMETER ( NKM = 10 )
24200 PARAMETER ( TINY = 1.D-20 )
24201
24202C input/output channels
24203 INTEGER LI,LO
24204 COMMON /POINOU/ LI,LO
24205C event debugging information
24206 INTEGER NMAXD
24207 PARAMETER (NMAXD=100)
24208 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24209 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24210 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24211 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24212C data on most recent hard scattering
24213 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24214 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24215 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24216 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24217 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24218 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24219 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24220 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24221 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24222C hard cross sections and MC selection weights
24223 INTEGER Max_pro_2
24224 PARAMETER ( Max_pro_2 = 16 )
24225 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24226 & MH_acc_1,MH_acc_2
24227 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24228 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24229 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24230 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24231 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24232 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24233
24234 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24235 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24236 DIMENSION IFTAB(-1:Max_pro_2)
24237 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24238
24239C initial settings
24240 AH = (2.D0*PTCUT/ECM)**2
24241 ALNH = LOG(AH)
24242 FF(0) = 0.D0
24243 DO 22 I=1,NKM
24244 FF(I) = 0.D0
24245 XM1(I) = 0.D0
24246 XM2(I) = 0.D0
24247 PTM(I) = 0.D0
24248 ZMX(1,I) = 0.D0
24249 ZMX(2,I) = 0.D0
24250 ZMX(3,I) = 0.D0
24251 DMX(1,I) = 0.D0
24252 DMX(2,I) = 0.D0
24253 DMX(3,I) = 0.D0
24254 IMX(I) = 0
24255 IPO(I) = 0
24256 22 CONTINUE
24257
24258 NKML = 10
24259 DO 40 NKON=1,NKML
24260
24261 DO 50 IST=1,3
24262C start configuration
24263 IF(IST.EQ.1) THEN
24264 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24265 Z(2) = 0.5
24266 Z(3) = 0.1
24267 D(1) =-0.5
24268 D(2) = 0.5
24269 D(3) = 0.5
24270 ELSE IF(IST.EQ.2) THEN
24271 Z(1) = 0.999D0
24272 Z(2) = 0.5
24273 Z(3) = 0.0
24274 D(1) =-0.5
24275 D(2) = 0.5
24276 D(3) = 0.5
24277 ELSE IF(IST.EQ.3) THEN
24278 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24279 Z(2) = 0.1
24280 Z(3) = 0.1
24281 D(1) =-0.5
24282 D(2) = 0.5
24283 D(3) = 0.5
24284 ELSE IF(IST.EQ.4) THEN
24285 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24286 Z(2) = 0.9
24287 Z(3) = 0.1
24288 D(1) =-0.5
24289 D(2) = 0.5
24290 D(3) = 0.5
24291 ENDIF
24292 IT = 0
24293 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24294C process possible?
24295 IF(F2.LE.0.D0) GOTO 35
24296
24297 10 CONTINUE
24298 IT = IT+1
24299 FOLD = F2
24300 DO 30 I=1,3
24301 D(I) = D(I)/5.D0
24302 Z(I) = Z(I)+D(I)
24303 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24304 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24305 IF ( F2.GT.F3 ) D(I) =-D(I)
24306 20 CONTINUE
24307 F1 = MIN(F2,F3)
24308 F2 = MAX(F2,F3)
24309 Z(I) = Z(I)+D(I)
24310 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24311 IF ( F3.GT.F2 ) GOTO 20
24312 ZZ = Z(I)-D(I)
24313 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24314 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24315 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24316 IF ( F1.LE.F2 ) Z(I) = ZZ
24317 F2 = MAX(F1,F2)
24318 30 CONTINUE
24319 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24320
24321 IF(F2.GT.FF(NKON)) THEN
24322 FF(NKON) = MAX(F2,0.D0)
24323 XM1(NKON) = X1
24324 XM2(NKON) = X2
24325 PTM(NKON) = PT
24326 ZMX(1,NKON) = Z(1)
24327 ZMX(2,NKON) = Z(2)
24328 ZMX(3,NKON) = Z(3)
24329 DMX(1,NKON) = D(1)
24330 DMX(2,NKON) = D(2)
24331 DMX(3,NKON) = D(3)
24332 IMX(NKON) = IT
24333 IPO(NKON) = IST
24334 ENDIF
24335C
24336 50 CONTINUE
24337 35 CONTINUE
24338 40 CONTINUE
24339
24340C debug output
24341 IF(IDEB(38).GE.5) THEN
24342 WRITE(LO,'(/1X,A)')
24343 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24344 DO 60 I=1,NKM
24345 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24346 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24347 & DMX(2,I),DMX(3,I)
24348 60 CONTINUE
24349 ENDIF
24350
24351 DO 70 I=-1,Max_pro_2
24352 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24353 70 CONTINUE
24354
24355C debug output
24356 IF(IDEB(38).GE.5) THEN
24357 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24358 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24359 DO 80 I=-1,Max_pro_2
24360 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24361 MSPR = I
24362 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24363 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24364 PT = PTM(IFTAB(I))
24365 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24366 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24367 ENDIF
24368 80 CONTINUE
24369 ENDIF
24370
24371 END
24372
24373*$ CREATE PHO_HARWGI.FOR
24374*COPY PHO_HARWGI
24375CDECK ID>, PHO_HARWGI
24376 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24377C**********************************************************************
24378C
24379C auxiliary subroutine to find maximum of remaining weight
24380C
24381C input: ECMX current CMS energy
24382C PTCUT current pt cutoff
24383C NKON process label 1..5 resolved
24384C 6..7 direct particle 1
24385C 8..9 direct particle 2
24386C 10 double direct
24387C Z(3) transformed variable
24388C
24389C output: remaining weight
24390C
24391C**********************************************************************
24392 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24393 SAVE
24394
24395 DIMENSION Z(3)
24396
24397 PARAMETER ( NKM = 10 )
24398 PARAMETER ( TINY = 1.D-30,
24399 & TINY6 = 1.D-06 )
24400
24401C input/output channels
24402 INTEGER LI,LO
24403 COMMON /POINOU/ LI,LO
24404C event debugging information
24405 INTEGER NMAXD
24406 PARAMETER (NMAXD=100)
24407 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24408 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24409 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24410 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24411C model switches and parameters
24412 CHARACTER*8 MDLNA
24413 INTEGER ISWMDL,IPAMDL
24414 DOUBLE PRECISION PARMDL
24415 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24416C data of c.m. system of Pomeron / Reggeon exchange
24417 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24418 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24419 & SIDP,CODP,SIFP,COFP
24420 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24421 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24422 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24423C currently activated parton density parametrizations
24424 CHARACTER*8 PDFNAM
24425 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24426 DOUBLE PRECISION PDFLAM,PDFQ2M
24427 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24428 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24429C hard scattering parameters used for most recent hard interaction
24430 INTEGER NFbeta,NF
24431 DOUBLE PRECISION ALQCD2,BQCD
24432 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24433C some hadron information, will be deleted in future versions
24434 INTEGER NFS
24435 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24436 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24437C scale parameters for parton model calculations
24438 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24439 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24440 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24441 & NQQAL,NQQALI,NQQALF,NQQPD
24442C data on most recent hard scattering
24443 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24444 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24445 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24446 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24447 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24448 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24449 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24450 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24451 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24452
24453 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24454 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24455
24456 FDIS = 0.D0
24457
24458 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24459 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24460C check input values
24461 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24462 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24463 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24464C transformations
24465 Y1 = EXP(ALNH*Z(1))
24466 IF(NKON.LE.5) THEN
24467C resolved kinematic
24468 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24469 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24470 X2 = X1-Y2
24471 X1 = MIN(X1,0.999999999999D0)
24472 X2 = MIN(X2,0.999999999999D0)
24473 ELSE IF(NKON.LE.7) THEN
24474C direct kinematic 1
24475 X1 = 1.D0
24476 X2 = MIN(Y1,0.999999999999D0)
24477 ELSE IF(NKON.LE.9) THEN
24478C direct kinematic 2
24479 X1 = MIN(Y1,0.999999999999D0)
24480 X2 = 1.D0
24481 ELSE
24482C double direct kinematic
24483 X1 = 1.D0
24484 X2 = 1.D0
24485 ENDIF
24486 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24487 V =-0.5D0+W*(Z(3)-0.5D0)
24488 U =-(1.D0+V)
24489 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24490
24491C set hard scale QQ for alpha and partondistr.
24492 IF ( NQQAL.EQ.1 ) THEN
24493 QQAL = AQQAL*PT*PT
24494 ELSEIF ( NQQAL.EQ.2 ) THEN
24495 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24496 ELSEIF ( NQQAL.EQ.3 ) THEN
24497 QQAL = AQQAL*Y1*ECMX*ECMX
24498 ELSEIF ( NQQAL.EQ.4 ) THEN
24499 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24500 ENDIF
24501 IF ( NQQPD.EQ.1 ) THEN
24502 QQPD = AQQPD*PT*PT
24503 ELSEIF ( NQQPD.EQ.2 ) THEN
24504 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24505 ELSEIF ( NQQPD.EQ.3 ) THEN
24506 QQPD = AQQPD*Y1*ECMX*ECMX
24507 ELSEIF ( NQQPD.EQ.4 ) THEN
24508 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24509 ENDIF
24510C
24511 IF(NKON.LE.5) THEN
24512 DO 10 N=1,5
24513 F(N) = 0.D0
24514 10 CONTINUE
24515C resolved processes
24516 ALPHA1 = PHO_ALPHAS(QQAL,3)
24517 ALPHA2 = ALPHA1
24518 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24519 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24520C calculate full distribution FDIS
24521 DO 20 I=1,NF
24522 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24523 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24524 F(4) = F(4)+PDA(I)+PDA(-I)
24525 F(5) = F(5)+PDB(I)+PDB(-I)
2452620 CONTINUE
24527 F(1) = PDA(0)*PDB(0)
24528 T = PDA(0)*F(5)+PDB(0)*F(4)
24529 F(5) = F(4)*F(5)-(F(2)+F(3))
24530 F(4) = T
24531 ELSE IF(NKON.LE.7) THEN
24532C direct processes particle 1
24533 IF(IDPDG1.EQ.22) THEN
24534 ALPHA1 = pho_alphae(QQAL)
24535 CH1 = 4.D0/9.D0
24536 CH2 = 3.D0/9.D0
24537 ELSE IF(IDPDG1.EQ.990) THEN
24538 ALPHA1 = PARMDL(74)
24539 CH1 = 1.D0
24540 CH2 = 0.D0
24541 ELSE
24542 FDIS = -1.D0
24543 RETURN
24544 ENDIF
24545 ALPHA2 = PHO_ALPHAS(QQAL,2)
24546 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24547 F(6) = 0.D0
24548 DO 30 I=1,NF
24549 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24550 30 CONTINUE
24551 F(7) = PDB(0)
24552 ELSE IF(NKON.LE.9) THEN
24553C direct processes particle 2
24554 ALPHA1 = PHO_ALPHAS(QQAL,1)
24555 IF(IDPDG2.EQ.22) THEN
24556 ALPHA2 = pho_alphae(QQAL)
24557 CH1 = 4.D0/9.D0
24558 CH2 = 3.D0/9.D0
24559 ELSE IF(IDPDG2.EQ.990) THEN
24560 ALPHA2 = PARMDL(74)
24561 CH1 = 1.D0
24562 CH2 = 0.D0
24563 ELSE
24564 FDIS = -1.D0
24565 RETURN
24566 ENDIF
24567 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24568 F(8) = 0.D0
24569 DO 40 I=1,NF
24570 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24571 40 CONTINUE
24572 F(9) = PDA(0)
24573 ELSE
24574C double direct process
24575 SSR = ECMX*ECMX
24576 IF(IDPDG1.EQ.22) THEN
24577 ALPHA1 = pho_alphae(SSR)
24578 ELSE IF(IDPDG1.EQ.990) THEN
24579 ALPHA1 = PARMDL(74)
24580 ELSE
24581 FDIS = -1.D0
24582 RETURN
24583 ENDIF
24584 IF(IDPDG2.EQ.22) THEN
24585 ALPHA2 = pho_alphae(SSR)
24586 ELSE IF(IDPDG2.EQ.990) THEN
24587 ALPHA2 = PARMDL(74)
24588 ELSE
24589 FDIS = -1.D0
24590 RETURN
24591 ENDIF
24592 F(10) = 1.D0
24593 ENDIF
24594
24595 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24596
24597C debug output
24598 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24599 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24600 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24601
24602 END
24603
24604*$ CREATE PHO_HARINI.FOR
24605*COPY PHO_HARINI
24606CDECK ID>, PHO_HARINI
24607 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24608C**********************************************************************
24609C
24610C initialize calculation of hard cross section
24611C
24612C must not be called during MC generation
24613C
24614C***********************************************************************
24615 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24616 SAVE
24617
24618 PARAMETER ( DEPS = 1.D-10 )
24619
24620C input/output channels
24621 INTEGER LI,LO
24622 COMMON /POINOU/ LI,LO
24623C event debugging information
24624 INTEGER NMAXD
24625 PARAMETER (NMAXD=100)
24626 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24627 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24628 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24629 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24630C model switches and parameters
24631 CHARACTER*8 MDLNA
24632 INTEGER ISWMDL,IPAMDL
24633 DOUBLE PRECISION PARMDL
24634 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24635C currently activated parton density parametrizations
24636 CHARACTER*8 PDFNAM
24637 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24638 DOUBLE PRECISION PDFLAM,PDFQ2M
24639 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24640 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24641C some constants
24642 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24643 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24644 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24645C scale parameters for parton model calculations
24646 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24647 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24648 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24649 & NQQAL,NQQALI,NQQALF,NQQPD
24650C data of c.m. system of Pomeron / Reggeon exchange
24651 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24652 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24653 & SIDP,CODP,SIFP,COFP
24654 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24655 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24656 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24657C obsolete cut-off information
24658 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24659 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24660C hard scattering parameters used for most recent hard interaction
24661 INTEGER NFbeta,NF
24662 DOUBLE PRECISION ALQCD2,BQCD
24663 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24664
24665 double precision pho_alphas
24666
24667 CHARACTER*20 RFLAG
24668
24669C set local Pomeron c.m. system data
24670 IDPDG1 = IDP1
24671 IDPDG2 = IDP2
24672 PVIRTP(1) = PV1
24673 PVIRTP(2) = PV2
24674C initialize PDFs
24675 CALL PHO_ACTPDF(IDPDG1,1)
24676 CALL PHO_ACTPDF(IDPDG2,2)
24677C initialize alpha_s calculation
24678 DUMMY = PHO_ALPHAS(0.D0,-4)
24679C initialize scales with defaults
24680 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24681 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24682 AQQAL = PARMDL(83)
24683 AQQALI = PARMDL(86)
24684 AQQALF = PARMDL(89)
24685 AQQPD = PARMDL(92)
24686 NQQAL = IPAMDL(83)
24687 NQQALI = IPAMDL(86)
24688 NQQALF = IPAMDL(89)
24689 NQQPD = IPAMDL(92)
24690 ELSE
24691 AQQAL = PARMDL(82)
24692 AQQALI = PARMDL(85)
24693 AQQALF = PARMDL(88)
24694 AQQPD = PARMDL(91)
24695 NQQAL = IPAMDL(82)
24696 NQQALI = IPAMDL(85)
24697 NQQALF = IPAMDL(88)
24698 NQQPD = IPAMDL(91)
24699 ENDIF
24700 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24701 AQQAL = PARMDL(82)
24702 AQQALI = PARMDL(85)
24703 AQQALF = PARMDL(88)
24704 AQQPD = PARMDL(91)
24705 NQQAL = IPAMDL(82)
24706 NQQALI = IPAMDL(85)
24707 NQQALF = IPAMDL(88)
24708 NQQPD = IPAMDL(91)
24709 ELSE
24710 AQQAL = PARMDL(81)
24711 AQQALI = PARMDL(84)
24712 AQQALF = PARMDL(87)
24713 AQQPD = PARMDL(90)
24714 NQQAL = IPAMDL(81)
24715 NQQALI = IPAMDL(84)
24716 NQQALF = IPAMDL(87)
24717 NQQPD = IPAMDL(90)
24718 ENDIF
24719 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24720 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24721 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24722 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24723 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24724 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24725 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24726 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24727 AQQAL = PARMDL(109+IP)
24728 AQQALI = PARMDL(113+IP)
24729 AQQALF = PARMDL(117+IP)
24730 AQQPD = PARMDL(121+IP)
24731 NQQAL = IPAMDL(64+IP)
24732 NQQALI = IPAMDL(68+IP)
24733 NQQALF = IPAMDL(72+IP)
24734 NQQPD = IPAMDL(76+IP)
24735 PTCUT(1) = PARMDL(36)
24736 PTCUT(2) = PARMDL(37)
24737 PTCUT(3) = PARMDL(38)
24738 PTCUT(4) = PARMDL(39)
24739 PTANO(1) = PARMDL(130)
24740 PTANO(2) = PARMDL(131)
24741 PTANO(3) = PARMDL(132)
24742 PTANO(4) = PARMDL(133)
24743 RFLAG = '(energy-independent)'
24744 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24745
24746C write out all settings
24747 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24748 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24749 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24750 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24751 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
247521050 FORMAT(/,
24753 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24754 & 5X,'particle 1 / particle 2:',2I8,/,
24755 & 5X,'min. PT :',F7.1,2X,A,/,
24756 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24757 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24758 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24759 & 5X,'max. number of active flavours NF :',I3,/,
24760 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24761 ENDIF
24762
24763 END
24764
24765*$ CREATE PHO_HARINT.FOR
24766*COPY PHO_HARINT
24767CDECK ID>, PHO_HARINT
24768 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24769C**********************************************************************
24770C
24771C interpolate cross sections and weights for hard scattering
24772C
24773C input: IPP particle combination (neg. for add. user cuts)
24774C ECM CMS energy (GeV)
24775C P2V1/2 particle virtualities (pos., GeV**2)
24776C I1 first subprocess to calculate
24777C I2 last subprocess to calculate
24778C <-1 only scales and cutoffs calculated
24779C K1 first variable to calculate
24780C K2 last variable to calculate
24781C MSPOM cross sections to use for pt distribution
24782C 0 reggeon
24783C >0 pomeron
24784C
24785C for K1 < 3 the soft pt distribution is also calculated
24786C
24787C output: interpolated values in HWgx, HSig, Hdpt
24788C
24789C***********************************************************************
24790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24791 SAVE
24792
24793 PARAMETER ( DEPS = 1.D-15,
24794 & DEPS2 = 2.D-15 )
24795
24796C input/output channels
24797 INTEGER LI,LO
24798 COMMON /POINOU/ LI,LO
24799C event debugging information
24800 INTEGER NMAXD
24801 PARAMETER (NMAXD=100)
24802 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24803 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24804 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24805 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24806C model switches and parameters
24807 CHARACTER*8 MDLNA
24808 INTEGER ISWMDL,IPAMDL
24809 DOUBLE PRECISION PARMDL
24810 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24811C Reggeon phenomenology parameters
24812 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24813 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24814 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24815 & ALREG,ALREGP,GR(2),B0REG(2),
24816 & GPPP,GPPR,B0PPP,B0PPR,
24817 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24818C parameters of 2x2 channel model
24819 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24820 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24821C data needed for soft-pt calculation
24822 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24823 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24824C scale parameters for parton model calculations
24825 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24826 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24827 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24828 & NQQAL,NQQALI,NQQALF,NQQPD
24829C obsolete cut-off information
24830 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24831 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24832C event weights and generated cross section
24833 INTEGER IPOWGC,ISWCUT,IVWGHT
24834 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24835 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24836 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24837C parameters for DGLAP backward evolution in ISR
24838 INTEGER NFSISR
24839 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24840 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24841C hard cross sections and MC selection weights
24842 INTEGER Max_pro_2
24843 PARAMETER ( Max_pro_2 = 16 )
24844 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24845 & MH_acc_1,MH_acc_2
24846 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24847 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24848 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24849 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24850 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24851 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24852C interpolation tables for hard cross section and MC selection weights
24853 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24854 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24855 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24856 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24857 & HQ2a_tab,HQ2b_tab,HEcm_tab
24858 COMMON /POHTAB/
24859 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24860 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24861 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24862 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24863 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24864 & HEcm_tab(1:Max_tab_E,0:4),
24865 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24866C data on most recent hard scattering
24867 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24868 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24869 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24870 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24871 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24872 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24873 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24874 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24875 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24876C energy-interpolation table
24877 INTEGER IEETA2
24878 PARAMETER ( IEETA2 = 20 )
24879 INTEGER ISIMAX
24880 DOUBLE PRECISION SIGTAB,SIGECM
24881 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24882
24883 DOUBLE PRECISION XP,PTS
24884 DIMENSION XP(2),PTS(0:2,2)
24885
24886 INTEGER IV
24887 DIMENSION IV(2)
24888
24889 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24890 & 'PHO_HARINT: called with ',
24891 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24892 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24893
24894 IP = ABS(IPP)
24895 IF(IPP.GT.0) THEN
24896C default minimum bias cutoff
24897 PTCUT(IP) = pho_ptcut(ECM,IP)
24898 ELSE
24899C user defined additional cutoff
24900 PTCUT(IP) = HSWCUT(4+IP)
24901 ENDIF
24902 PTWANT = PTCUT(IP)
24903
24904C ISR cutoffs
24905 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24906 Q2MISR(1) = MAX(P2V1,Q2CUT)
24907 Q2MISR(2) = MAX(P2V2,Q2CUT)
24908C cutoff for direct photon contribution to photon PDF
24909 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24910 PTA1 = PTANO(IP)
24911C scales for hard scattering
24912 AQQAL = PARMDL(109+IP)
24913 AQQALI = PARMDL(113+IP)
24914 AQQALF = PARMDL(117+IP)
24915 AQQPD = PARMDL(121+IP)
24916 NQQAL = IPAMDL(64+IP)
24917 NQQALI = IPAMDL(68+IP)
24918 NQQALF = IPAMDL(72+IP)
24919 NQQPD = IPAMDL(76+IP)
24920 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24921 & 'PHO_HARINT: scales:',
24922 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24923
24924 IF(I2.LT.-1) RETURN
24925
24926 IL = IP
24927 IF(IPP.LT.0) IL = 0
24928
24929C double-log interpolation
24930 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24931 DO 50 M=I1,I2
24932 Hfac(M) = 0.D0
24933 HWgx(M) = 0.D0
24934 HSig(M) = 0.D0
24935 Hdpt(M) = 0.D0
24936 50 CONTINUE
24937 ELSE
24938 I=1
24939 310 CONTINUE
24940 I = I+1
24941 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24942
24943 Ia = 1
24944 Ib = 1
24945 fac = LOG(ECM/HEcm_tab(I-1,IL))
24946 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24947 do M=I1,I2
24948C factor due to phase space integration
24949 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24950 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24951 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24952 XX = EXP(XX)
24953 IF(XX.LT.DEPS2) XX = 0.D0
24954 Hfac(M) = XX
24955C max. weight
24956 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24957 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24958 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24959 XX = EXP(XX)
24960 IF(XX.LT.DEPS2) XX = 0.D0
24961 HWgx(M) = XX*1.2D0
24962C hard cross section
24963 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24964 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24965 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24966 XX = EXP(XX)
24967 IF(XX.LT.DEPS2) XX = 0.D0
24968 HSig(M) = XX
24969C differential hard cross section
24970 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24971 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24972 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24973 XX = EXP(XX)
24974 IF(XX.LT.DEPS2) XX = 0.D0
24975 Hdpt(M) = XX
24976 enddo
24977 ENDIF
24978
24979 IF((K1.LT.3).AND.(K2.GE.3)) THEN
24980C cross check
24981 IF((I1.GT.9).OR.(I2.LT.9)) THEN
24982 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24983 & 'hard cross section not calculated ',I1,I2
24984 ENDIF
24985 SIGH = HSig(9)
24986 DSIGHP = Hdpt(9)
24987C load soft cross sections from interpolation table
24988 IF(ECM.LE.SIGECM(IP,1)) THEN
24989 L1 = 1
24990 L2 = 1
24991 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24992 DO 55 I=2,ISIMAX
24993 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24994 55 CONTINUE
24995 205 CONTINUE
24996 L1 = I-1
24997 L2 = I
24998 ELSE
24999 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25000 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25001 & IP,ECM,SIGECM(IP,ISIMAX)
25002 CALL PHO_PREVNT(-1)
25003 L1 = ISIMAX-1
25004 L2 = ISIMAX
25005 ENDIF
25006 FAC2=0.D0
25007 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25008 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25009 FAC1=1.D0-FAC2
25010 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25011 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25012
25013 FS = FPS(IP)
25014 FH = FPH(IP)
25015 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25016 ENDIF
25017
25018 300 CONTINUE
25019
25020C debug output
25021 IF(IDEB(58).GE.15) THEN
25022 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25023 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25024 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25025 DO 162 M=I1,I2
25026 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25027 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25028 162 CONTINUE
25029 ENDIF
25030
25031 END
25032
25033*$ CREATE PHO_PTCUT.FOR
25034*COPY PHO_PTCUT
25035 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25036C***********************************************************************
25037C
25038C calculate energy-dependent transverse momentum cutoff
25039C
25040C***********************************************************************
25041 IMPLICIT NONE
25042 SAVE
25043
25044 double precision ECM
25045 integer IP
25046
25047C input/output channels
25048 INTEGER LI,LO
25049 COMMON /POINOU/ LI,LO
25050C event debugging information
25051 INTEGER NMAXD
25052 PARAMETER (NMAXD=100)
25053 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25054 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25055 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25056 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25057C model switches and parameters
25058 CHARACTER*8 MDLNA
25059 INTEGER ISWMDL,IPAMDL
25060 DOUBLE PRECISION PARMDL
25061 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25062
25063 pho_ptcut = PARMDL(35+IP)
25064
25065 IF(IPAMDL(7).EQ.1) THEN
25066C Bopp et al. type (DPMJET)
25067 pho_ptcut = PARMDL(35+IP)
25068 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25069 ELSE IF(IPAMDL(7).EQ.2) THEN
25070C Gribov-Levin-Ryskin type
25071 pho_ptcut = PARMDL(35+IP)
25072 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25073 ENDIF
25074
25075 END
25076
25077*$ CREATE PHO_HARMCI.FOR
25078*COPY PHO_HARMCI
25079CDECK ID>, PHO_HARMCI
25080 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25081C**********************************************************************
25082C
25083C initialize MC sampling and calculate hard cross section
25084C
25085C input: IP particle combination (neg. number for user cut)
25086C EMAXF maximum CMS energy for
25087C interpolation table in reference to PTCUT(1..4)
25088C
25089C***********************************************************************
25090 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25091 SAVE
25092
25093 PARAMETER (DEPS = 1.D-10,
25094 & PLARGE = 1.D20 )
25095
25096C input/output channels
25097 INTEGER LI,LO
25098 COMMON /POINOU/ LI,LO
25099C event debugging information
25100 INTEGER NMAXD
25101 PARAMETER (NMAXD=100)
25102 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25103 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25104 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25105 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25106C some constants
25107 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25108 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25109 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25110C global event kinematics and particle IDs
25111 INTEGER IFPAP,IFPAB
25112 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25113 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25114C data of c.m. system of Pomeron / Reggeon exchange
25115 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25116 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25117 & SIDP,CODP,SIFP,COFP
25118 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25119 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25120 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25121C model switches and parameters
25122 CHARACTER*8 MDLNA
25123 INTEGER ISWMDL,IPAMDL
25124 DOUBLE PRECISION PARMDL
25125 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25126C obsolete cut-off information
25127 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25128 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25129C scale parameters for parton model calculations
25130 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25131 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25132 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25133 & NQQAL,NQQALI,NQQALF,NQQPD
25134C names of hard scattering processes
25135 INTEGER Max_pro_1
25136 PARAMETER ( Max_pro_1 = 16 )
25137 CHARACTER*18 PROC
25138 COMMON /POHPRO/ PROC(0:Max_pro_1)
25139C hard cross sections and MC selection weights
25140 INTEGER Max_pro_2
25141 PARAMETER ( Max_pro_2 = 16 )
25142 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25143 & MH_acc_1,MH_acc_2
25144 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25145 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25146 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25147 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25148 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25149 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25150C interpolation tables for hard cross section and MC selection weights
25151 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25152 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25153 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25154 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25155 & HQ2a_tab,HQ2b_tab,HEcm_tab
25156 COMMON /POHTAB/
25157 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25158 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25159 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25160 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25161 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25162 & HEcm_tab(1:Max_tab_E,0:4),
25163 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25164C event weights and generated cross section
25165 INTEGER IPOWGC,ISWCUT,IVWGHT
25166 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25167 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25168 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25169
25170 COMPLEX*16 DSIG
25171 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25172
25173C initialization for all pt cutoffs
25174 I = ABS(IP)
25175 IL = I
25176 IF(IP.LT.0) THEN
25177 IL = 0
25178 PTC = HSWCUT(4+I)
25179 else
25180 PTC = pho_ptcut(parmdl(19),I)
25181 ENDIF
25182
25183C skip unassigned PTCUT
25184 IF(PTC.LT.0.5D0) GOTO 1000
25185
25186 IH_Q2a_up(I) = 1
25187 IH_Q2b_up(I) = 1
25188 do ib=1,Max_tab_Q2
25189 do ia=1,Max_tab_Q2
25190 do ie=1,Max_tab_E
25191 do m=-1,Max_pro_2
25192 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25193 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25194 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25195 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25196 enddo
25197 enddo
25198 enddo
25199 enddo
25200
25201 ELLOW = LOG(2.05*PTC)
25202 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25203C energy too low
25204 IF(DELTA.LE.0.D0) GOTO 1000
25205
25206C switch between external particles and Pomeron
25207 IF(I.EQ.4) THEN
25208 IDP1 = 990
25209 PV1 = 0.D0
25210 IDP2 = 990
25211 PV2 = 0.D0
25212 ELSE IF(I.EQ.3) THEN
25213 IDP1 = IFPAP(2)
25214 PV1 = PVIRT(2)
25215 IDP2 = 990
25216 PV2 = 0.D0
25217 ELSE IF(I.EQ.2) THEN
25218 IDP1 = IFPAP(1)
25219 PV1 = PVIRT(1)
25220 IDP2 = 990
25221 PV2 = 0.D0
25222 ELSE
25223 IDP1 = IFPAP(1)
25224 PV1 = PVIRT(1)
25225 IDP2 = IFPAP(2)
25226 PV2 = PVIRT(2)
25227 ENDIF
25228
25229C initialize PT scales
25230 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25231 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25232 FPS(I) = PARMDL(105)
25233 FPH(I) = PARMDL(106)
25234 ELSE
25235 FPS(I) = PARMDL(103)
25236 FPH(I) = PARMDL(104)
25237 ENDIF
25238 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25239 FPS(I) = PARMDL(103)
25240 FPH(I) = PARMDL(104)
25241 ELSE
25242 FPS(I) = PARMDL(101)
25243 FPH(I) = PARMDL(102)
25244 ENDIF
25245
25246C initialize hard scattering
25247 IF(IP.GT.0) THEN
25248 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25249 ELSE
25250 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25251 ENDIF
25252
25253C energy/virtuality grid
25254 do Ie=1,IH_Ecm_up(IL)
25255 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25256 enddo
25257 do Ia=1,IH_Q2a_up(IL)
25258 HQ2a_tab(Ia,IL) = 0.D0
25259 enddo
25260 do Ib=1,IH_Q2b_up(IL)
25261 HQ2b_tab(Ib,IL) = 0.D0
25262 enddo
25263
25264C initialization for several energies and particle virtualities
25265 do Ie=1,IH_Ecm_up(IL)
25266 do Ia=1,IH_Q2a_up(IL)
25267 do Ib=1,IH_Q2b_up(IL)
25268
25269 EE = HEcm_tab(IE,IL)
25270 Q2a = HQ2a_tab(Ia,IL)
25271 Q2b = HQ2b_tab(Ib,IL)
25272 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25273 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25274 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25275 & PTCUT(I),EE,IDPDG1,IDPDG2
25276 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25277 CALL PHO_HARFAC(PTCUT(I),EE)
25278 CALL PHO_HARWGX(PTCUT(I),EE)
25279 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25280 IF(IDEB(8).GE.10) THEN
25281 WRITE(LO,'(1X,A,/,1X,A)')
25282 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25283 & '------------------------------------------------'
25284 DO M=0,Max_pro_2
25285 WRITE(LO,'(10X,A,1P2E14.4)')
25286 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25287 ENDDO
25288 ENDIF
25289
25290C store in interpolation tables
25291 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25292 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25293 do M=0,Max_pro_2
25294 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25295 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25296 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25297 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25298 enddo
25299
25300C summed quantities
25301 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25302 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25303 do M=1,8
25304 IF(MH_pro_on(M,I).GT.0) THEN
25305 HSig_tab(9,IE,Ia,Ib,IL) =
25306 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25307 Hdpt_tab(9,IE,Ia,Ib,IL) =
25308 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25309 ENDIF
25310 enddo
25311 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25312 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25313 do M=10,14
25314 IF(MH_pro_on(M,I).GT.0) THEN
25315 HSig_tab(15,IE,Ia,Ib,IL) =
25316 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25317 Hdpt_tab(15,IE,Ia,Ib,IL) =
25318 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25319 ENDIF
25320 enddo
25321 HSig_tab(0,IE,Ia,Ib,IL) =
25322 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25323 Hdpt_tab(0,IE,Ia,Ib,IL) =
25324 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25325
25326 enddo
25327 enddo
25328 enddo
25329
25330C debug output of weights
25331 1000 CONTINUE
25332 IF(IDEB(8).GE.5) THEN
25333 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25334 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25335 & IDPDG1,IDPDG2,IP,PTCUT(I),
25336 & '------------------------------------------'
25337 DO M=-1,Max_pro_2
25338 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25339 WRITE(LO,'(2X,A,I3,2I7)')
25340 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25341 & M,IDPDG1,IDPDG2
25342 do k=1,IH_Ecm_up(IL)
25343 do ia=1,IH_Q2a_up(IL)
25344 do ib=1,IH_Q2b_up(IL)
25345 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25346 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25347 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25348 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25349 enddo
25350 enddo
25351 enddo
25352 512 CONTINUE
25353 ENDDO
25354 ENDIF
25355
25356 END
25357
25358*$ CREATE PHO_HARXR3.FOR
25359*COPY PHO_HARXR3
25360CDECK ID>, PHO_HARXR3
25361 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25362C**********************************************************************
25363C
25364C differential cross section DSIG/(DETAC*DETAD*DPT)
25365C
25366C input: ECMH CMS energy
25367C PT parton PT
25368C ETAC pseudorapidity of parton C
25369C ETAD pseudorapidity of parton D
25370C
25371C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25372C
25373C**********************************************************************
25374 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25375 SAVE
25376
25377 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25378
25379 PARAMETER ( Max_pro_2 = 16 )
25380 COMPLEX*16 DSIGMC
25381 DIMENSION DSIGMC(0:Max_pro_2)
25382 DIMENSION DSIGM(0:Max_pro_2)
25383
25384C input/output channels
25385 INTEGER LI,LO
25386 COMMON /POINOU/ LI,LO
25387C some constants
25388 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25389 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25390 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25391C Reggeon phenomenology parameters
25392 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25393 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25394 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25395 & ALREG,ALREGP,GR(2),B0REG(2),
25396 & GPPP,GPPR,B0PPP,B0PPR,
25397 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25398C currently activated parton density parametrizations
25399 CHARACTER*8 PDFNAM
25400 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25401 DOUBLE PRECISION PDFLAM,PDFQ2M
25402 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25403 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25404C hard scattering parameters used for most recent hard interaction
25405 INTEGER NFbeta,NF
25406 DOUBLE PRECISION ALQCD2,BQCD
25407 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25408C scale parameters for parton model calculations
25409 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25410 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25411 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25412 & NQQAL,NQQALI,NQQALF,NQQPD
25413
25414 DOUBLE PRECISION PHO_ALPHAS
25415 DIMENSION PDA(-6:6),PDB(-6:6)
25416
25417 DO 10 I=1,9
25418 DSIGMC(I) = CMPLX(0.D0,0.D0)
25419 DSIGM(I) = 0.D0
2542010 CONTINUE
25421
25422 EC = EXP(ETAC)
25423 ED = EXP(ETAD)
25424C kinematic conversions
25425 XA = PT*(EC+ED)/ECMH
25426 XB = XA/(EC*ED)
25427 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25428 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25429 RETURN
25430 ENDIF
25431 SP = XA*XB*ECMH*ECMH
25432 UP =-ECMH*PT*EC*XB
25433 UP = UP/SP
25434 TP =-(1.D0+UP)
25435 UU = UP*UP
25436 TT = TP*TP
25437C set hard scale QQ for alpha and partondistr.
25438 IF ( NQQAL.EQ.1 ) THEN
25439 QQAL = AQQAL*PT*PT
25440 ELSEIF ( NQQAL.EQ.2 ) THEN
25441 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25442 ELSEIF ( NQQAL.EQ.3 ) THEN
25443 QQAL = AQQAL*SP
25444 ELSEIF ( NQQAL.EQ.4 ) THEN
25445 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25446 ENDIF
25447 IF ( NQQPD.EQ.1 ) THEN
25448 QQPD = AQQPD*PT*PT
25449 ELSEIF ( NQQPD.EQ.2 ) THEN
25450 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25451 ELSEIF ( NQQPD.EQ.3 ) THEN
25452 QQPD = AQQPD*SP
25453 ELSEIF ( NQQPD.EQ.4 ) THEN
25454 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25455 ENDIF
25456
25457 ALPHA = PHO_ALPHAS(QQAL,3)
25458 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25459C parton distributions (times x)
25460 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25461 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25462 S1 = PDA(0)*PDB(0)
25463 S2 = 0.D0
25464 S3 = 0.D0
25465 S4 = 0.D0
25466 S5 = 0.D0
25467 DO 20 I=1,NF
25468 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25469 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25470 S4 = S4+PDA(I)+PDA(-I)
25471 S5 = S5+PDB(I)+PDB(-I)
2547220 CONTINUE
25473C partial cross sections (including color and symmetry factors)
25474C resolved photon matrix elements (light quarks)
25475 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25476 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25477 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25478 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25479 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25480 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25481 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25482 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25483 & (8.D0/27.D0)/(UP*TP))
25484C
25485 DSIGM(1) = FACTOR*DSIGM(1)*S1
25486 DSIGM(2) = FACTOR*DSIGM(2)*S2
25487 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25488 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25489 DSIGM(5) = FACTOR*DSIGM(5)*S2
25490 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25491 DSIGM(7) = FACTOR*DSIGM(7)*S3
25492 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25493C complex part
25494 X=ABS(TP-UP)
25495 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25496C
25497 DO 50 I=1,8
25498 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25499 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25500 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25501 50 CONTINUE
25502 END
25503
25504*$ CREATE PHO_HARXR2.FOR
25505*COPY PHO_HARXR2
25506CDECK ID>, PHO_HARXR2
25507 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25508C**********************************************************************
25509C
25510C differential cross section DSIG/(DETAC*DPT)
25511C
25512C input: ECMH CMS energy
25513C PT parton PT
25514C ETAC pseudorapidity of parton C
25515C
25516C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25517C
25518C**********************************************************************
25519 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25520 SAVE
25521
25522 PARAMETER ( TINY= 1.D-20 )
25523
25524 PARAMETER ( Max_pro_2 = 16 )
25525 COMPLEX*16 DSIGMC
25526 DIMENSION DSIGMC(0:Max_pro_2)
25527
25528C input/output channels
25529 INTEGER LI,LO
25530 COMMON /POINOU/ LI,LO
25531C integration precision for hard cross sections (obsolete)
25532 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25533 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25534
25535 COMPLEX*16 DSIG1
25536 DIMENSION DSIG1(0:Max_pro_2)
25537 DIMENSION ABSZ(32),WEIG(32)
25538
25539 DO 10 M=1,9
25540 DSIGMC(M) = CMPLX(0.D0,0.D0)
25541 DSIG1(M) = 0.D0
2554210 CONTINUE
25543C
25544 EC = EXP(ETAC)
25545 ARG = ECMH/PT
25546 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25547 EDU = LOG(ARG-EC)
25548 EDL =-LOG(ARG-1.D0/EC)
25549 NPOINT = NGAUET
25550 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25551 DO 30 I=1,NPOINT
25552 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25553 DO 20 M=1,9
25554 PCTRL= DREAL(DSIG1(M))/TINY
25555 IF( PCTRL.GE.1.D0 ) THEN
25556 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25557 ENDIF
2555820 CONTINUE
2555930 CONTINUE
25560 END
25561
25562*$ CREATE PHO_HARXD2.FOR
25563*COPY PHO_HARXD2
25564CDECK ID>, PHO_HARXD2
25565 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25566C**********************************************************************
25567C
25568C differential cross section DSIG/(DETAC*DPT) for direct processes
25569C
25570C input: ECMH CMS energy of scattering system
25571C PT parton PT
25572C ETAC pseudorapidity of parton C
25573C
25574C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25575C
25576C**********************************************************************
25577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25578 SAVE
25579
25580 PARAMETER ( Max_pro_2 = 16 )
25581 COMPLEX*16 DSIGMC
25582 DIMENSION DSIGMC(0:Max_pro_2)
25583 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25584
25585C input/output channels
25586 INTEGER LI,LO
25587 COMMON /POINOU/ LI,LO
25588C model switches and parameters
25589 CHARACTER*8 MDLNA
25590 INTEGER ISWMDL,IPAMDL
25591 DOUBLE PRECISION PARMDL
25592 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25593C data of c.m. system of Pomeron / Reggeon exchange
25594 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25595 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25596 & SIDP,CODP,SIFP,COFP
25597 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25598 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25599 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25600C Reggeon phenomenology parameters
25601 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25602 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25603 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25604 & ALREG,ALREGP,GR(2),B0REG(2),
25605 & GPPP,GPPR,B0PPP,B0PPR,
25606 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25607C currently activated parton density parametrizations
25608 CHARACTER*8 PDFNAM
25609 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25610 DOUBLE PRECISION PDFLAM,PDFQ2M
25611 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25612 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25613C hard scattering parameters used for most recent hard interaction
25614 INTEGER NFbeta,NF
25615 DOUBLE PRECISION ALQCD2,BQCD
25616 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25617C some hadron information, will be deleted in future versions
25618 INTEGER NFS
25619 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25620 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25621C scale parameters for parton model calculations
25622 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25623 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25624 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25625 & NQQAL,NQQALI,NQQALF,NQQPD
25626C some constants
25627 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25628 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25629 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25630
25631 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25632 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25633
25634* ONE32=1.D0/9.D0
25635* TWO32=4.D0/9.D0
25636 DO 10 I=10,13
25637 DSIGMC(I) = CMPLX(0.D0,0.D0)
25638 DSIGM(I) = 0.D0
25639 10 CONTINUE
25640 DSIGMC(15) = CMPLX(0.D0,0.D0)
25641 DSIGM(15) = 0.D0
25642
25643C direct particle 1
25644 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25645 EC = EXP(ETAC)
25646 ED = ECMH/PT-EC
25647C kinematic conversions
25648 XA = 1.D0
25649 XB = 1.D0/(EC*ED)
25650 IF ( XB.GE.1.D0 ) THEN
25651 WRITE(LO,'(/1X,A,2E12.4)')
25652 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25653 RETURN
25654 ENDIF
25655 SP = XA*XB*ECMH*ECMH
25656 UP =-ECMH*PT*EC*XB
25657 UP = UP/SP
25658 TP =-(1.D0+UP)
25659 UU = UP*UP
25660 TT = TP*TP
25661C set hard scale QQ for alpha and partondistr.
25662 IF ( NQQAL.EQ.1 ) THEN
25663 QQAL = AQQAL*PT*PT
25664 ELSEIF ( NQQAL.EQ.2 ) THEN
25665 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25666 ELSEIF ( NQQAL.EQ.3 ) THEN
25667 QQAL = AQQAL*SP
25668 ELSEIF ( NQQAL.EQ.4 ) THEN
25669 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25670 ENDIF
25671 IF ( NQQPD.EQ.1 ) THEN
25672 QQPD = AQQPD*PT*PT
25673 ELSEIF ( NQQPD.EQ.2 ) THEN
25674 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25675 ELSEIF ( NQQPD.EQ.3 ) THEN
25676 QQPD = AQQPD*SP
25677 ELSEIF ( NQQPD.EQ.4 ) THEN
25678 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25679 ENDIF
25680
25681 ALPHA2 = PHO_ALPHAS(QQAL,2)
25682 IF(IDPDG1.EQ.22) THEN
25683 ALPHA1 = pho_alphae(QQAL)
25684 ELSE IF(IDPDG1.EQ.990) THEN
25685 ALPHA1 = PARMDL(74)
25686 ENDIF
25687 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25688C parton distribution (times x)
25689 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25690 S1 = PDB(0)
25691C charge counting
25692 S2 = 0.D0
25693 S3 = 0.D0
25694 IF(IDPDG1.EQ.22) THEN
25695 DO 20 I=1,NF
25696* IF(MOD(I,2).EQ.0) THEN
25697* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25698* S3 = S3 + TWO32
25699* ELSE
25700* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25701* S3 = S3 + ONE32
25702* ENDIF
25703 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25704 S3 = S3 + Q_ch2(I)
25705 20 CONTINUE
25706 ELSE IF(IDPDG1.EQ.990) THEN
25707 DO 25 I=1,NF
25708 S2 = S2 + PDB(I)+PDB(-I)
25709 25 CONTINUE
25710 S3 = NF
25711 ENDIF
25712C partial cross sections (including color and symmetry factors)
25713C direct photon matrix elements
25714 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25715 DSIGM(11) = (UU+TT)/(UP*TP)
25716C
25717 DSIGM(10) = FACTOR*DSIGM(10)*S2
25718 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25719C complex part
25720 X=ABS(TP-UP)
25721 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25722C
25723 DO 50 I=10,11
25724 IF(DSIGM(I).LT.0.D0) THEN
25725 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25726 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25727 DSIGM(I) = 0.D0
25728 ENDIF
25729 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25730 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25731 50 CONTINUE
25732 ENDIF
25733C
25734C direct particle 2
25735 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25736 EC = EXP(ETAC)
25737 ED = 1.D0/(ECMH/PT-1.D0/EC)
25738C kinematic conversions
25739 XA = PT*(EC+ED)/ECMH
25740 XB = 1.D0
25741 IF ( XA.GE.1.D0 ) THEN
25742 WRITE(LO,'(/1X,A,2E12.4)')
25743 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25744 RETURN
25745 ENDIF
25746 SP = XA*XB*ECMH*ECMH
25747 UP =-ECMH*PT*EC*XB
25748 UP = UP/SP
25749 TP =-(1.D0+UP)
25750 UU = UP*UP
25751 TT = TP*TP
25752C set hard scale QQ for alpha and partondistr.
25753 IF ( NQQAL.EQ.1 ) THEN
25754 QQAL = AQQAL*PT*PT
25755 ELSEIF ( NQQAL.EQ.2 ) THEN
25756 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25757 ELSEIF ( NQQAL.EQ.3 ) THEN
25758 QQAL = AQQAL*SP
25759 ELSEIF ( NQQAL.EQ.4 ) THEN
25760 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25761 ENDIF
25762 IF ( NQQPD.EQ.1 ) THEN
25763 QQPD = AQQPD*PT*PT
25764 ELSEIF ( NQQPD.EQ.2 ) THEN
25765 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25766 ELSEIF ( NQQPD.EQ.3 ) THEN
25767 QQPD = AQQPD*SP
25768 ELSEIF ( NQQPD.EQ.4 ) THEN
25769 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25770 ENDIF
25771
25772 ALPHA1 = PHO_ALPHAS(QQAL,1)
25773 IF(IDPDG2.EQ.22) THEN
25774 ALPHA2 = pho_alphae(QQAL)
25775 ELSE IF(IDPDG2.EQ.990) THEN
25776 ALPHA2 = PARMDL(74)
25777 ENDIF
25778 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25779C parton distribution (times x)
25780 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25781 S1 = PDA(0)
25782C charge counting
25783 S2 = 0.D0
25784 S3 = 0.D0
25785 IF(IDPDG2.EQ.22) THEN
25786 DO 70 I=1,NF
25787* IF(MOD(I,2).EQ.0) THEN
25788* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25789* S3 = S3 + TWO32
25790* ELSE
25791* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25792* S3 = S3 + ONE32
25793* ENDIF
25794 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25795 S3 = S3 + Q_ch2(I)
25796 70 CONTINUE
25797 ELSE IF(IDPDG2.EQ.990) THEN
25798 DO 75 I=1,NF
25799 S2 = S2 + PDA(I)+PDA(-I)
25800 75 CONTINUE
25801 S3 = NF
25802 ENDIF
25803C partial cross sections (including color and symmetry factors)
25804C direct photon matrix elements
25805 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25806 DSIGM(13) = (UU+TT)/(UP*TP)
25807C
25808 DSIGM(12) = FACTOR*DSIGM(12)*S2
25809 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25810C complex part
25811 X=ABS(TP-UP)
25812 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25813C
25814 DO 80 I=12,13
25815 IF(DSIGM(I).LT.0.D0) THEN
25816 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25817 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25818 DSIGM(I) = 0.D0
25819 ENDIF
25820 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25821 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25822 80 CONTINUE
25823 ENDIF
25824 END
25825
25826*$ CREATE PHO_HARXPT.FOR
25827*COPY PHO_HARXPT
25828CDECK ID>, PHO_HARXPT
25829 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25830C**********************************************************************
25831C
25832C differential cross section DSIG/DPT
25833C
25834C input: ECMH CMS energy of scattering system
25835C PT parton PT
25836C IPRO 1 resolved processes
25837C 2 direct processes
25838C 3 resolved and direct processes
25839C
25840C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25841C
25842C**********************************************************************
25843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25844 SAVE
25845
25846 PARAMETER ( Max_pro_2 = 16 )
25847 COMPLEX*16 DSIGMC
25848 DIMENSION DSIGMC(0:Max_pro_2)
25849 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25850
25851C input/output channels
25852 INTEGER LI,LO
25853 COMMON /POINOU/ LI,LO
25854C some constants
25855 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25856 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25857 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25858C model switches and parameters
25859 CHARACTER*8 MDLNA
25860 INTEGER ISWMDL,IPAMDL
25861 DOUBLE PRECISION PARMDL
25862 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25863C data of c.m. system of Pomeron / Reggeon exchange
25864 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25865 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25866 & SIDP,CODP,SIFP,COFP
25867 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25868 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25869 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25870C Reggeon phenomenology parameters
25871 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25872 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25873 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25874 & ALREG,ALREGP,GR(2),B0REG(2),
25875 & GPPP,GPPR,B0PPP,B0PPR,
25876 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25877C integration precision for hard cross sections (obsolete)
25878 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25879 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25880C hard scattering parameters used for most recent hard interaction
25881 INTEGER NFbeta,NF
25882 DOUBLE PRECISION ALQCD2,BQCD
25883 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25884C some hadron information, will be deleted in future versions
25885 INTEGER NFS
25886 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25887 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25888
25889 double precision pho_alphae
25890
25891 COMPLEX*16 DSIG1
25892 DIMENSION DSIG1(0:Max_pro_2)
25893 DIMENSION ABSZ(32),WEIG(32)
25894
25895 DO 10 M=0,Max_pro_2
25896 DSIGMC(M) = CMPLX(0.D0,0.D0)
25897 DSIG1(M) = CMPLX(0.D0,0.D0)
25898 10 CONTINUE
25899
25900C resolved and direct processes
25901 AMT = 2.D0*PT/ECMH
25902 IF ( AMT.GE.1.D0 ) RETURN
25903 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25904 ECL = -ECU
25905 NPOINT = NGAUET
25906 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25907 DO 30 I=1,NPOINT
25908 DSIG1(9) = CMPLX(0.D0,0.D0)
25909 DSIG1(15) = CMPLX(0.D0,0.D0)
25910 IF(IPRO.EQ.1) THEN
25911 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25912 ELSE IF(IPRO.EQ.2) THEN
25913 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25914 ELSE
25915 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25916 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25917 ENDIF
25918 DO 20 M=1,Max_pro_2
25919 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25920 20 CONTINUE
25921 30 CONTINUE
25922
25923C direct processes
25924 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25925 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25926 FAC = 0.D0
25927 SS = ECMH*ECMH
25928 ALPHAE = pho_alphae(SS)
25929 DO 300 I=1,NF
25930 IF(IDPDG1.EQ.22) THEN
25931* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25932 F1 = Q_ch2(I)*ALPHAE
25933 ELSE
25934 F1 = PARMDL(74)
25935 ENDIF
25936 IF(IDPDG2.EQ.22) THEN
25937* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25938 F2 = Q_ch2(I)*ALPHAE
25939 ELSE
25940 F2 = PARMDL(74)
25941 ENDIF
25942 FAC = FAC+F1*F2*3.D0
25943 300 CONTINUE
25944C direct cross sections
25945 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25946 T1 = -SS/2.D0*(1.D0+ZZ)
25947 T2 = -SS/2.D0*(1.D0-ZZ)
25948 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25949C hadronic part
25950 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25951
25952C leptonic part (e, mu, tau)
25953 DSIGMC(16) = 0.D0
25954 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25955 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25956C simulation of tau together with quarks
25957 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25958 ENDIF
25959 ENDIF
25960
25961 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25962 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
25963
25964 END
25965
25966*$ CREATE PHO_HARXTO.FOR
25967*COPY PHO_HARXTO
25968CDECK ID>, PHO_HARXTO
25969 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25970C**********************************************************************
25971C
25972C total hard cross section (perturbative QCD, Parton Model)
25973C
25974C input: ECMH CMS energy of scattering system
25975C PTCUTR PT cutoff for resolved processes
25976C PTCUTD PT cutoff for direct processes (photon, Pomeron)
25977C
25978C output: DSIGMC(0:MARPR2) cross sections for given cutoff
25979C DSDPTC(0:MARPR2) differential cross sections at cutoff
25980C
25981C note: COMPLEX*16 DSIGMC
25982C DOUBLE PRECISION DSDPTC
25983C
25984C**********************************************************************
25985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25986 SAVE
25987
25988 PARAMETER ( Max_pro_2 = 16 )
25989 COMPLEX*16 DSIGMC
25990 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25991
25992C input/output channels
25993 INTEGER LI,LO
25994 COMMON /POINOU/ LI,LO
25995C model switches and parameters
25996 CHARACTER*8 MDLNA
25997 INTEGER ISWMDL,IPAMDL
25998 DOUBLE PRECISION PARMDL
25999 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26000C data of c.m. system of Pomeron / Reggeon exchange
26001 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26002 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26003 & SIDP,CODP,SIFP,COFP
26004 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26005 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26006 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26007C Reggeon phenomenology parameters
26008 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26009 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26010 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26011 & ALREG,ALREGP,GR(2),B0REG(2),
26012 & GPPP,GPPR,B0PPP,B0PPR,
26013 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26014C some constants
26015 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26016 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26017 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26018C integration precision for hard cross sections (obsolete)
26019 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26020 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26021C some hadron information, will be deleted in future versions
26022 INTEGER NFS
26023 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26024 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26025C hard scattering parameters used for most recent hard interaction
26026 INTEGER NFbeta,NF
26027 DOUBLE PRECISION ALQCD2,BQCD
26028 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26029
26030 double precision pho_alphae
26031
26032 COMPLEX*16 DSIG1
26033 DIMENSION DSIG1(0:Max_pro_2)
26034 DIMENSION ABSZ(32),WEIG(32)
26035
26036 DATA FAC / 3.0D0 /
26037
26038 DO 10 M=0,Max_pro_2
26039 DSIGMC(M)= CMPLX(0.D0,0.D0)
26040 10 CONTINUE
26041 EEC=ECMH/2.001D0
26042C
26043 IF ( PTCUTR.GE.EEC ) GOTO 100
26044C
26045C integration for resolved processes
26046 PTMIN = PTCUTR
26047 PTMAX = MIN(FAC*PTMIN,EEC)
26048 NPOINT = NGAUP1
26049 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26050 DO 60 M=1,9
26051 DSDPTC(M) = DREAL(DSIG1(M))
26052 60 CONTINUE
26053 DSIGH = DREAL(DSIG1(9))
26054 PTMXX = 0.95D0*PTMAX
26055 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26056 DSIGL = DREAL(DSIG1(9))
26057 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26058 EX1 = 1.0D0-EX
26059 DO 50 K=1,2
26060 IF ( PTMIN.GE.PTMAX ) GOTO 40
26061 RL = PTMIN**EX1
26062 RU = PTMAX**EX1
26063 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26064 DO 30 I=1,NPOINT
26065 R = ABSZ(I)
26066 PT = R**(1.0D0/EX1)
26067 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26068 F = WEIG(I)*PT/(R*EX1)
26069 DO 20 M=1,9
26070 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26071 20 CONTINUE
26072 30 CONTINUE
26073 40 PTMIN = PTMAX
26074 PTMAX = EEC
26075 NPOINT = NGAUP2
26076 50 CONTINUE
26077 100 CONTINUE
26078 DSIGMC(0) = DSIGMC(9)
26079 DSDPTC(0) = DSDPTC(9)
26080C
26081C integration for direct processes
26082 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26083C
26084 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26085 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26086 PTMIN = PTCUTD
26087 PTMAX = MIN(FAC*PTMIN,EEC)
26088 NPOINT = NGAUP1
26089 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26090 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26091 DO 160 M=10,16
26092 DSDPTC(M) = DREAL(DSIG1(M))
26093 160 CONTINUE
26094 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26095 PTMXX = 0.95D0*PTMAX
26096 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26097 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26098 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26099 EX1 = 1.0D0-EX
26100 DO 150 K=1,2
26101 IF ( PTMIN.GE.PTMAX ) GOTO 140
26102 RL = PTMIN**EX1
26103 RU = PTMAX**EX1
26104 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26105 DO 130 I=1,NPOINT
26106 R = ABSZ(I)
26107 PT = R**(1.0D0/EX1)
26108 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26109 F = WEIG(I)*PT/(R*EX1)
26110 DO 120 M=10,15
26111 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26112 120 CONTINUE
26113 130 CONTINUE
26114 140 PTMIN = PTMAX
26115 PTMAX = EEC
26116 NPOINT = NGAUP2
26117 150 CONTINUE
26118 ENDIF
26119C
26120 170 CONTINUE
26121C
26122C double direct process
26123 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26124 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26125 FACC = 0.D0
26126 SS = ECMH*ECMH
26127 ALPHAE = pho_alphae(SS)
26128 DO 300 I=1,NF
26129 IF(IDPDG1.EQ.22) THEN
26130* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26131 F1 = Q_ch2(I)*ALPHAE
26132 ELSE
26133 F1 = PARMDL(74)
26134 ENDIF
26135 IF(IDPDG2.EQ.22) THEN
26136* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26137 F2 = Q_ch2(I)*ALPHAE
26138 ELSE
26139 F2 = PARMDL(74)
26140 ENDIF
26141 FACC = FACC + F1*F2*3.D0
26142 300 CONTINUE
26143
26144 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26145 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26146C hadronic cross section
26147 DSIGMC(14) = R*FACC*AKFAC
26148C leptonic cross section
26149 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26150 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26151C simulation of tau together with quarks
26152 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26153 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26154 ELSE
26155 DSIGMC(16) = CMPLX(0.D0,0.D0)
26156 ENDIF
26157C sum of direct part
26158 DSIGMC(15) = CMPLX(0.D0,0.D0)
26159 DO 400 I=10,14
26160 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26161 400 CONTINUE
26162 ENDIF
26163C total sum (hadronic)
26164 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26165 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26166
26167 END
26168
26169*$ CREATE PHO_HARISR.FOR
26170*COPY PHO_HARISR
26171CDECK ID>, PHO_HARISR
26172 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26173 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26174C********************************************************************
26175C
26176C initial state radiation according to DGLAP evolution equations
26177C (backward evolution, no spin effects)
26178C
26179C input: IHPOM index of hard Pomeron
26180C negative: delete all previous entries
26181C P1,P2 4 momenta of hard scattered final partons
26182C (in CMS of hard scattering)
26183C IPF1,2 flavours of final partons
26184C IPA1,2 flavours of initial partons
26185C IV1,2 valence quark labels (0/1)
26186C Q2H momentum transfer (squared, positive)
26187C XH1,XH2 x values of initial partons
26188C XHMAX1,2 max. x values allowed
26189C
26190C output: all emitted partons in /POPISR/, final state
26191C partons are the first two entries
26192C shower evolution traced in /PODGL1/
26193C IPB1,2 flavours of new initial partons
26194C XISR1,2 x values of new initial partons
26195C IVO1,2 valence quark labels (0/1)
26196C
26197C attention: quark numbering according to PDG convention,
26198C but 0 for gluons
26199C
26200C********************************************************************
26201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26202 SAVE
26203
26204 PARAMETER (RHOMAS = 0.766D0,
26205 & DEPS = 1.D-10,
26206 & TINY = 1.D-10)
26207
26208 DIMENSION P1(4),P2(4)
26209
26210C input/output channels
26211 INTEGER LI,LO
26212 COMMON /POINOU/ LI,LO
26213C event debugging information
26214 INTEGER NMAXD
26215 PARAMETER (NMAXD=100)
26216 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26217 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26218 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26219 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26220C internal rejection counters
26221 INTEGER NMXJ
26222 PARAMETER (NMXJ=60)
26223 CHARACTER*10 REJTIT
26224 INTEGER IFAIL
26225 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26226C model switches and parameters
26227 CHARACTER*8 MDLNA
26228 INTEGER ISWMDL,IPAMDL
26229 DOUBLE PRECISION PARMDL
26230 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26231C data of c.m. system of Pomeron / Reggeon exchange
26232 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26233 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26234 & SIDP,CODP,SIFP,COFP
26235 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26236 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26237 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26238C some hadron information, will be deleted in future versions
26239 INTEGER NFS
26240 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26241 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26242C currently activated parton density parametrizations
26243 CHARACTER*8 PDFNAM
26244 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26245 DOUBLE PRECISION PDFLAM,PDFQ2M
26246 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26247 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26248C scale parameters for parton model calculations
26249 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26250 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26251 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26252 & NQQAL,NQQALI,NQQALF,NQQPD
26253C parameters for DGLAP backward evolution in ISR
26254 INTEGER NFSISR
26255 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26256 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26257C initial state parton radiation (internal part)
26258 INTEGER MXISR3,MXISR4
26259 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26260 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26261 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26262 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26263 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26264 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26265 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26266C some constants
26267 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26268 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26269 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26270C particles created by initial state evolution
26271 INTEGER MXISR1,MXISR2
26272 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26273 INTEGER IFLISR,IPOISR,IMXISR
26274 DOUBLE PRECISION PHISR
26275 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26276 & IPOISR(2,2,MXISR2),IMXISR(2)
26277
26278 DOUBLE PRECISION PYP,EER,THER,QMAXR
26279 INTEGER PYK
26280
26281 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26282 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26283 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26284
26285 IREJ = 0
26286 NTRY = 1000
26287 NITER = 0
26288C debug output
26289 IF(IDEB(79).GE.10) THEN
26290 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26291 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26292 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26293 ENDIF
26294 IF(IHPOM.EQ.0) RETURN
26295C
26296 10 CONTINUE
26297 NACC = 0
26298 IDMO(1) = IDPDG1
26299 IDMO(2) = IDPDG2
26300C
26301C copy final state partons to local fields
26302 IHIDX = ABS(IHPOM)
26303 IF(IHIDX.GT.MXISR2) THEN
26304 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26305 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26306 & IHIDX,MXISR2
26307 IREJ = 1
26308 ENDIF
26309 DO 50 K=1,2
26310 IF(IHPOM.LT.0) IMXISR(K) = 0
26311 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26312 IPAL(K) = IPOISR(K,1,IHIDX)
26313 50 CONTINUE
26314 DO 55 I=1,4
26315 PHISR(1,I,IPAL(1)) = P1(I)
26316 PHISR(2,I,IPAL(2)) = P2(I)
26317 55 CONTINUE
26318 IFLISR(1,IPAL(1)) = IPF1
26319 IFLISR(2,IPAL(2)) = IPF2
26320C
26321C check limitations, initialize /PODGL1/
26322 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26323 NEXT(1) = 1
26324 Q2SH(1,1) = Q2H
26325 ELSE
26326 NEXT(1) = 0
26327 Q2SH(1,1) = 0.D0
26328 ENDIF
26329 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26330 NEXT(2) = 1
26331 Q2SH(2,1) = Q2H
26332 ELSE
26333 NEXT(2) = 0
26334 Q2SH(2,1) = 0.D0
26335 ENDIF
26336C
26337 ISH(1) = 1
26338 ISH(2) = 1
26339 XPSH(1,1) = XH1
26340 XPSH(2,1) = XH2
26341C
26342 IFL1(1,1) = IPA1
26343 IVAL(1) = IV1
26344 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26345 IFL1(2,1) = IPA2
26346 IVAL(2) = IV2
26347 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26348C
26349 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26350 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26351 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26352C
26353C initialize parton shower loop
26354 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26355 AL2ISR(1) = PDFLAM(1)
26356 AL2ISR(2) = PDFLAM(2)
26357 XHMA(1) = XHMAX1
26358 XHMA(2) = XHMAX2
26359 XHMI(1) = PMISR(1)/PCMP
26360 XHMI(2) = PMISR(2)/PCMP
26361 ZPSH(1,1) = 1.D0
26362 ZPSH(2,1) = 1.D0
26363 SHAT1 = XH1*XH2*ECMP**2
26364 IF(IPAMDL(109).EQ.1) THEN
26365 PT2SH(1,1) = Q2H
26366 ELSE
26367 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26368 ENDIF
26369 PT2SH(2,1) = PT2SH(1,1)
26370 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26371 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26372 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26373 THSH(2,1) = THSH(1,1)
26374 IFANO(1) = 0
26375 IFANO(2) = 0
26376 ZZ = 1.D0
26377 IF(IREJ.NE.0) GOTO 800
26378C
26379C main generation loop
26380C -------------------------------------------------
26381 100 CONTINUE
26382C choose parton side to become solved
26383 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26384 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26385 IP = 1
26386 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26387 IP = 2
26388 ELSE
26389 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26390 ENDIF
26391 ELSE IF(NEXT(1).EQ.1) THEN
26392 IP = 1
26393 ELSE IF(NEXT(2).EQ.1) THEN
26394 IP = 2
26395 ELSE
26396 GOTO 800
26397 ENDIF
26398 INDX = ISH(IP)
26399C INDX now parton position of parton to become solved
26400C IP now side to be treated
26401 XP = XPSH(IP,INDX)
26402 Q2P = Q2SH(IP,INDX)
26403 PT2 = PT2SH(IP,INDX)
26404 IFLB = IFL1(IP,INDX)
26405C check available x
26406 XMIP = XHMI(IP)
26407C cutoff by x limitation: no further development
26408 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26409 NEXT(IP) = 0
26410 Q2SH(IP,INDX) = 0.D0
26411 IF(IDEB(79).GE.17) THEN
26412 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26413 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26414 & XP,XMIP,XHMA(IP),IP,INDX
26415 ENDIF
26416 GOTO 100
26417 ENDIF
26418C initial value of evolution variable t
26419 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26420 DO 110 I=-NFSISR,NFSISR
26421 WGGAP(I) = 0.D0
26422 WGPDF(I) = 0.D0
26423 110 CONTINUE
26424C DGLAP weights
26425 ZMIN = XP/XHMA(IP)
26426 ZMAX = XP/(XP+XMIP)
26427 CF = 4./3.
26428C q --> q g, g --> g g
26429 IF(IFLB.EQ.0) THEN
26430 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26431 & +2.D0*LOG(ZMAX/ZMIN))
26432 DO 120 I=1,NFSISR
26433 WGGAP(I) = WGGAP(0)
26434 WGGAP(-I) = WGGAP(0)
26435 120 CONTINUE
26436 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26437 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26438C q --> g q, g --> q qb
26439 ELSE IF(ABS(IFLB).LE.6) THEN
26440 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26441 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26442 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26443 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26444 ELSE
26445 WRITE(LO,'(/1X,A,I7)')
26446 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26447 CALL PHO_ABORT
26448 ENDIF
26449C anomalous/resolved evolution
26450 IPDFC = 0
26451 IF(IPAMDL(110).GE.1) THEN
26452 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26453 & .AND.(IFLB.NE.21)) THEN
26454 WGDIR = 0.D0
26455 IF(NQQALI.EQ.1) THEN
26456 SCALE2 = PT2*AQQPD
26457 ELSE
26458 SCALE2 = Q2P*AQQPD
26459 ENDIF
26460 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26461 IPDFC = 1
26462 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26463 XI = DT_RNDM(XP)*PD1(IFLB)
26464 IF(WGDIR.GT.XI) THEN
26465C debug output
26466 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26467 & 'PHO_HARISR: ',
26468 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26469 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26470 Q2SH(IP,INDX) = 0.D0
26471 NEXT(IP) = 0
26472 IFANO(IP) = INDX
26473 GOTO 100
26474 ENDIF
26475 ENDIF
26476 ENDIF
26477C
26478C rejection loop for z,t sampling
26479C ------------------------------------
26480 200 CONTINUE
26481 NITER = NITER+1
26482 IF(NITER.GE.NTRY) THEN
26483 WRITE(LO,'(1X,A,2I6)')
26484 & 'PHO_HARISR: too many rejections',NITER,NTRY
26485 CALL PHO_PREVNT(-1)
26486C clean up event
26487 IREJ = 1
26488 GOTO 10
26489 ENDIF
26490C PDF weights
26491 IF(IPDFC.EQ.0) THEN
26492 IF(NQQALI.EQ.1) THEN
26493 SCALE2 = PT2*AQQPD
26494 ELSE
26495 SCALE2 = Q2P*AQQPD
26496 ENDIF
26497 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26498 ENDIF
26499 IPDFC = 0
26500C
26501 WGTOT = 0.D0
26502 DO 210 I=-NFSISR,NFSISR
26503 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26504 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26505 210 CONTINUE
26506C
26507 215 CONTINUE
26508C sample new t value
26509 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26510 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26511C debug output
26512 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26513 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26514C compare to limits
26515 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26516 Q2SH(IP,INDX) = 0.D0
26517 NEXT(IP) = 0
26518 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26519 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26520 & Q2NEW,Q2MISR(IP),IP,INDX
26521 GOTO 100
26522 ENDIF
26523 Q2SH(IP,INDX) = Q2NEW
26524 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26525C selection of flavours
26526 XI = WGTOT*DT_RNDM(TT)
26527 IFLA = -NFSISR-1
26528 220 CONTINUE
26529 IFLA = IFLA+1
26530 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26531 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26532C debug output
26533 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26534 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26535C selection of z
26536 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26537C debug output
26538 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26539 & 'PHO_HARISR: pre-selected ZZ',ZZ
26540C angular ordering
26541 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26542 IF(THETA.GT.THSH(IP,INDX)) THEN
26543 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26544 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26545 & THETA,THSH(IP,INDX)
26546 GOTO 215
26547 ENDIF
26548C rejection weight given by new PDFs
26549 XNEW = XP/ZZ
26550 PT2NEW = Q2NEW*(1.D0-ZZ)
26551 IF(NQQALI.EQ.1) THEN
26552 SCALE2 = PT2NEW*AQQPD
26553 ELSE
26554 SCALE2 = Q2NEW*AQQPD
26555 ENDIF
26556 IF(SCALE2.LT.Q2MISR(IP)) THEN
26557 Q2SH(IP,INDX) = 0.D0
26558 NEXT(IP) = 0
26559 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26560 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26561 & Q2NEW,Q2MISR(IP),IP,INDX
26562 GOTO 100
26563 ENDIF
26564 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26565 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26566 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26567 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26568 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26569 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26570 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26571 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26572 WRITE(LO,'(1X,A,E12.3)')
26573 & 'PHO_HARISR: final weight:',WGF
26574 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26575 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26576 ENDIF
26577 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26578
26579 IF(IDEB(79).GE.15) THEN
26580 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26581 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26582 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26583 ENDIF
26584
26585 IF(INDX.GE.MXISR3) THEN
26586 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26587 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26588 IREJ = 1
26589 RETURN
26590 ENDIF
26591C branching accepted, registration
26592 Q2SH(IP,INDX) = Q2NEW
26593 PT2SH(IP,INDX) = PT2NEW
26594 ZPSH(IP,INDX) = ZZ
26595 IFL2(IP,INDX) = IFLA-IFLB
26596 Q2SH(IP,INDX+1) = Q2NEW
26597 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26598 XPSH(IP,INDX+1) = XNEW
26599 THSH(IP,INDX+1) = THETA
26600 IFL1(IP,INDX+1) = IFLA
26601 ISH(IP) = ISH(IP)+1
26602
26603 NACC = NACC+1
26604 IF(NACC.GT.MXISR4) THEN
26605 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26606 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26607 IREJ = 1
26608 RETURN
26609 ENDIF
26610 SHAT(NACC) = SHAT1
26611 IBRA(1,NACC) = IP
26612 IBRA(2,NACC) = INDX
26613 SHAT1 = SHAT1/ZZ
26614
26615C generation of next branching
26616 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26617
26618 800 CONTINUE
26619
26620C new initial flavours, x values
26621 IPB1 = IFL1(1,ISH(1))
26622 IPB2 = IFL1(2,ISH(2))
26623 XISR1 = XPSH(1,ISH(1))
26624 XISR2 = XPSH(2,ISH(2))
26625 IVO1 = IVAL(1)
26626 IVO2 = IVAL(2)
26627C valence flavours
26628 IF(IPB1.NE.0) THEN
26629 IF(ISH(1).GT.1) THEN
26630 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26631 IF(IDPDG1.EQ.22) THEN
26632 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26633 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26634 ELSE
26635 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26636 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26637 ENDIF
26638 ENDIF
26639 ENDIF
26640 IF(IPB2.NE.0) THEN
26641 IF(ISH(2).GT.1) THEN
26642 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26643 IF(IDPDG2.EQ.22) THEN
26644 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26645 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26646 ELSE
26647 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26648 ENDIF
26649 ENDIF
26650 ENDIF
26651
26652C parton kinematics
26653 IF(NACC.GT.0) THEN
26654C final partons in CMS
26655 PM(3) = (XH1-XH2)*ECMP/2.D0
26656 PM(4) = (XH1+XH2)*ECMP/2.D0
26657 SH = XH1*XH2*ECMP**2
26658 SSH = SQRT(SH)
26659 GB(3) = PM(3)/SSH
26660 GB(4) = PM(4)/SSH
26661 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26662 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26663 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26664 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26665 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26666 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26667 IL(1) = 1
26668 IL(2) = 1
26669 DO 900 I=1,NACC
26670 IPA = IBRA(1,I)
26671 IPB = 3-IPA
26672 IL(IPA) = IBRA(2,I)
26673C new initial partons in CMS
26674 SH = SHAT(I)
26675 SSH = SQRT(SH)
26676 SHZ = SH/ZPSH(IPA,IL(IPA))
26677 SSHZ = SQRT(SHZ)
26678 Q2(1) = Q2SH(1,IL(1))
26679 Q2(2) = Q2SH(2,IL(2))
26680 PC(1,1) = 0.D0
26681 PC(1,2) = 0.D0
26682 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26683 & /(2.D0*SSH)
26684 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26685 PC(2,1) = 0.D0
26686 PC(2,2) = 0.D0
26687 PC(2,3) = -PC(1,3)
26688 PC(2,4) = SSH-PC(1,4)
26689 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26690 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26691 S1 = SH+Q2(IPA)+Q2(IPB)
26692 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26693 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26694 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26695 IF(Q2(IPB).LT.0.1D0) THEN
26696 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26697 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26698 ELSE
26699 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26700 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26701 ENDIF
26702 NGEN = 1
26703C max. virtuality for time-like showers
26704 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26705 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26706C generate time-like parton shower
26707 KF = IFL2(IPA,IL(IPA))
26708 IF(KF.EQ.0) KF = 21
26709 EER = MIN(EE3-PC(IPA,4),ECMP)
26710 THER = 0.
26711 CALL PY1ENT(1,KF,EER,THER,THER)
26712 QMAXR = SQRT(QMAX)
26713 CALL PYSHOW(1,0,QMAXR)
26714C debug output
26715 IF(IDEB(79).GE.25) THEN
26716 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26717 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26718 & EER,QMAX,XMS4M,Q2(IPA)
26719 CALL PYLIST(1)
26720 ENDIF
26721 NGEN = PYK(0,1)
26722 IF(NGEN.GT.1) THEN
26723 PJX = 0.D0
26724 PJY = 0.D0
26725 PJZ = 0.D0
26726 PJE = 0.D0
26727 KK = IPAL(IPA)
26728 DO 820 K=3,NGEN
26729 IF(PYK(K,1).LE.4) THEN
26730 KK = KK+1
26731 IF(KK.GT.MXISR1) THEN
26732 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26733 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26734 IREJ = 1
26735 RETURN
26736 ENDIF
26737 PHISR(IPA,1,KK) = PYP(K,1)
26738 PJX = PJX+PHISR(IPA,1,KK)
26739 PHISR(IPA,2,KK) = PYP(K,2)
26740 PJY = PJY+PHISR(IPA,2,KK)
26741 PHISR(IPA,3,KK) = PYP(K,3)
26742 PJZ = PJZ+PHISR(IPA,3,KK)
26743 PHISR(IPA,4,KK) = PYP(K,4)
26744 PJE = PJE+PHISR(IPA,4,KK)
26745 IFLISR(IPA,KK) = PYK(K,2)
26746 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26747 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26748 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26749 ENDIF
26750 820 CONTINUE
26751 NGEN = KK-IPAL(IPA)
26752 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26753 PP4 = SQRT(PJE**2-XMS4)
26754 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26755C debug output
26756 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26757 & 'PHO_HARISR: ',
26758 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26759 & PJE,PJX,PJY,PJZ,PP4,XMS4
26760 ENDIF
26761 ENDIF
26762 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26763 & /(2.D0*PC(IPA,3))
26764 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26765 IF(PT3.LT.0.D0) THEN
26766 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26767 & 'PHO_HARISR: rejection due to PT3',PT3
26768 GOTO 10
26769 ENDIF
26770 PT3 = SQRT(PT3)
26771 CALL PHO_SFECFE(SFE,CFE)
26772 PX3 = CFE*PT3
26773 PY3 = SFE*PT3
26774C
26775 IF(NGEN.GT.1) THEN
26776C time-like shower generated
26777 EE4 = EE3-PC(IPA,4)
26778 PZ4 = PZ3-PC(IPA,3)
26779 PP4 = SQRT(PT3**2+PZ4**2)
26780C Lorentz boost
26781 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26782 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26783C rotation angles
26784 CODD = PZ4/PP4
26785 SIDD = SQRT(PX3**2+PY3**2)/PP4
26786 COFD = 1.D0
26787 SIFD = 0.D0
26788 IF(PP4*SIDD.GT.1.D-5) THEN
26789 COFD = PX3/(SIDD*PP4)
26790 SIFD = PY3/(SIDD*PP4)
26791 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26792 COFD = COFD/ANORF
26793 SIFD = SIFD/ANORF
26794 ENDIF
26795C copy partons back
26796 KK = IPAL(IPA)
26797 DO 830 K=1,NGEN
26798 KK = KK+1
26799 PX = PHISR(IPA,1,KK)
26800 PY = PHISR(IPA,2,KK)
26801 PZ = PHISR(IPA,3,KK)
26802 COH= PHISR(IPA,4,KK)
26803 EE = GAM*COH+BEG*PZ
26804 PZ = GAM*PZ +BEG*COH
26805 PHISR(IPA,4,KK) = EE
26806 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26807 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26808 830 CONTINUE
26809 IPAL(IPA) = KK
26810 ELSE
26811C no time-like shower generated
26812 IPAL(IPA) = IPAL(IPA)+1
26813 PHISR(IPA,1,IPAL(IPA)) = PX3
26814 PHISR(IPA,2,IPAL(IPA)) = PY3
26815 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26816 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26817 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
26818 ENDIF
26819 PC(IPA,1) = PX3
26820 PC(IPA,2) = PY3
26821 PC(IPA,3) = PZ3
26822 PC(IPA,4) = EE3
26823C boost / rotate into new CMS
26824 DO 842 K=1,4
26825 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26826 842 CONTINUE
26827 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26828 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26829 COG= PM(3)/PTOT1
26830 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26831 COH=1.D0
26832 SIH=0.D0
26833 IF(PTOT1*SIG.GT.1.D-5) THEN
26834 COH=PM(1)/(SIG*PTOT1)
26835 SIH=PM(2)/(SIG*PTOT1)
26836 ANORF=SQRT(COH*COH+SIH*SIH)
26837 COH=COH/ANORF
26838 SIH=SIH/ANORF
26839 ENDIF
26840 DO 845 K=1,2
26841 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26842 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26843 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26844 & PTOT1,PM(1),PM(2),PM(3),PM(4))
26845 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26846 & PN(2),PN(3))
26847 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26848 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26849 PHISR(K,4,L) = PM(4)
26850 844 CONTINUE
26851 845 CONTINUE
26852 900 CONTINUE
26853C boost back to global CMS
26854 PM(3) = (XISR1-XISR2)/2.D0
26855 PM(4) = (XISR1+XISR2)/2.D0
26856 SSH = SQRT(XISR1*XISR2)
26857 GB(3) = PM(3)/SSH
26858 GB(4) = PM(4)/SSH
26859 DO 945 K=1,2
26860 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26861 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26862 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26863 & PM(2),PM(3),PM(4))
26864 PHISR(K,1,L) = PM(1)
26865 PHISR(K,2,L) = PM(2)
26866 PHISR(K,3,L) = PM(3)
26867 PHISR(K,4,L) = PM(4)
26868 944 CONTINUE
26869 945 CONTINUE
26870 ENDIF
26871 IPOISR(1,2,IHIDX) = IPAL(1)
26872 IPOISR(2,2,IHIDX) = IPAL(2)
26873 IMXISR(1) = IPAL(1)
26874 IMXISR(2) = IPAL(2)
26875C
26876C debug output
26877 IF(IDEB(79).GE.10) THEN
26878 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26879 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26880 IF(NACC.GT.0) THEN
26881 WRITE(LO,'(1X,A,2I5,/6X,A)')
26882 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26883 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
26884 DO 600 II=1,NACC
26885 K = IBRA(1,II)
26886 I = IBRA(2,II)
26887 WRITE(LO,'(5X,4I5,4E11.3)')
26888 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26889 & ZPSH(K,I)
26890 600 CONTINUE
26891 ENDIF
26892C check of final configuration
26893 PX3 = 0.D0
26894 PY3 = 0.D0
26895 PZ3 = 0.D0
26896 EE3 = 0.D0
26897 IFSUM(1) = 0
26898 IFSUM(2) = 0
26899 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26900 DO 745 K=1,2
26901 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26902 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26903 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26904 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26905 PX3 = PX3 + PHISR(K,1,L)
26906 PY3 = PY3 + PHISR(K,2,L)
26907 PZ3 = PZ3 + PHISR(K,3,L)
26908 EE3 = EE3 + PHISR(K,4,L)
26909 744 CONTINUE
26910 745 CONTINUE
26911 IFSUM(1) = IFSUM(1)-IPB1
26912 IFSUM(2) = IFSUM(2)-IPB2
26913 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26914 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26915 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26916 & IFSUM,PX3,PY3,PZ3,EE3
26917 ENDIF
26918 END
26919
26920*$ CREATE PHO_HARZSP.FOR
26921*COPY PHO_HARZSP
26922CDECK ID>, PHO_HARZSP
26923 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26924C*********************************************************************
26925C
26926C sampling of z values from DGLAP kernels
26927C
26928C input: IFLA,IFLB parton flavours
26929C NFSH flavours involved in hard processes
26930C ZMIN minimal ZZ allowed
26931C ZMAX maximal ZZ allowed
26932C
26933C output: ZZ z value
26934C
26935C*********************************************************************
26936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26937 SAVE
26938
26939 PARAMETER ( DEPS = 1.D-10 )
26940
26941C input/output channels
26942 INTEGER LI,LO
26943 COMMON /POINOU/ LI,LO
26944C event debugging information
26945 INTEGER NMAXD
26946 PARAMETER (NMAXD=100)
26947 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26948 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26949 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26950 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26951C internal rejection counters
26952 INTEGER NMXJ
26953 PARAMETER (NMXJ=60)
26954 CHARACTER*10 REJTIT
26955 INTEGER IFAIL
26956 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26957
26958 IF(ZMAX.LE.ZMIN) THEN
26959 WRITE(LO,'(1X,A,2E12.3)')
26960 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26961 CALL PHO_PREVNT(-1)
26962 ZZ = 0.D0
26963 RETURN
26964 ENDIF
26965C
26966 IF(IFLB.EQ.0) THEN
26967 IF(IFLA.EQ.0) THEN
26968C g --> g g
26969 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26970 C2 = (1.D0-ZMIN)/ZMIN
26971 100 CONTINUE
26972 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26973 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26974 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26975C q --> q g
26976 C1 = ZMAX/ZMIN
26977 200 CONTINUE
26978 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26979 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26980 ELSE
26981 GOTO 900
26982 ENDIF
26983 ELSE IF(ABS(IFLB).LE.NFSH) THEN
26984 IF(IFLA.EQ.0) THEN
26985C g --> q qb
26986 C1 = ZMAX-ZMIN
26987 300 CONTINUE
26988 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26989 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26990 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26991C q --> g q
26992 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26993 C2 = 1.D0-ZMIN
26994 400 CONTINUE
26995 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26996 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
26997 ELSE
26998 GOTO 900
26999 ENDIF
27000 ELSE
27001 GOTO 900
27002 ENDIF
27003C debug output
27004 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27005 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27006 & IFLA,IFLB,ZZ,ZMIN,ZMAX
27007 RETURN
27008
27009 900 CONTINUE
27010 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27011 & IFLA,IFLB
27012 CALL PHO_ABORT
27013
27014 END
27015
27016*$ CREATE PHO_ALPHAE.FOR
27017*COPY PHO_ALPHAE
27018CDECK ID>, PHO_ALPHAE
27019 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27020C**********************************************************************
27021C
27022C calculation of ALPHA_em
27023C
27024C input: Q2 scale in GeV**2
27025C
27026C**********************************************************************
27027 IMPLICIT NONE
27028 SAVE
27029
27030 DOUBLE PRECISION Q2
27031
27032C input/output channels
27033 INTEGER LI,LO
27034 COMMON /POINOU/ LI,LO
27035C model switches and parameters
27036 CHARACTER*8 MDLNA
27037 INTEGER ISWMDL,IPAMDL
27038 DOUBLE PRECISION PARMDL
27039 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27040
27041 DOUBLE PRECISION PYALEM
27042
27043 pho_alphae = 1.D0/137.D0
27044
27045 if(ipamdl(120).eq.1) then
27046 pho_alphae = PYALEM(Q2)
27047 endif
27048
27049 END
27050
27051*$ CREATE PHO_ALPHAS.FOR
27052*COPY PHO_ALPHAS
27053CDECK ID>, PHO_ALPHAS
27054 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27055C**********************************************************************
27056C
27057C calculation of ALPHA_S
27058C
27059C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27060C 2 lambda_QCD**2 for PDF 2 evolution
27061C 3 lambda_QCD**2 for hard scattering
27062C Q2 scale in GeV**2
27063C
27064C initialization needed:
27065C IMODE = 0 lambda values taken from PDF table
27066C -1 given Q2 is 4-flavour lambda 1
27067C -2 given Q2 is 4-flavour lambda 2
27068C -3 given Q2 is 4-flavour lambda 3
27069C
27070C
27071C**********************************************************************
27072 IMPLICIT NONE
27073 SAVE
27074
27075 DOUBLE PRECISION Q2
27076 INTEGER IMODE
27077
27078C input/output channels
27079 INTEGER LI,LO
27080 COMMON /POINOU/ LI,LO
27081C model switches and parameters
27082 CHARACTER*8 MDLNA
27083 INTEGER ISWMDL,IPAMDL
27084 DOUBLE PRECISION PARMDL
27085 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27086C hard scattering parameters used for most recent hard interaction
27087 INTEGER NFbeta,NF
27088 DOUBLE PRECISION ALQCD2,BQCD
27089 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27090C currently activated parton density parametrizations
27091 CHARACTER*8 PDFNAM
27092 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27093 DOUBLE PRECISION PDFLAM,PDFQ2M
27094 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27095 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27096
27097 INTEGER I
27098
27099 PHO_ALPHAS = 0.D0
27100
27101 IF(IMODE.GT.0) THEN
27102
27103 IF(Q2.LT.PARMDL(148)) THEN
27104 NFbeta = 1
27105 ELSE IF(Q2.LT.PARMDL(149)) THEN
27106 NFbeta = 2
27107 ELSE IF(Q2.LT.PARMDL(150)) THEN
27108 NFbeta = 3
27109 ELSE
27110 NFbeta = 4
27111 ENDIF
27112
27113 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27114 NFbeta = NFbeta+2
27115
27116 ELSE IF(IMODE.EQ.0) THEN
27117
27118 DO I=1,3
27119 if(I.EQ.3) then
27120 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27121 else
27122 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27123 endif
27124 ALQCD2(I,1) = PARMDL(148)
27125 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27126 ALQCD2(I,3) = PARMDL(149)
27127 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27128 ALQCD2(I,4) = PARMDL(150)
27129 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27130
27131 ENDDO
27132
27133 ELSE IF(IMODE.LT.0) THEN
27134
27135 if(IMODE.eq.-4) then
27136 I = 3
27137 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27138 else
27139 I = -IMODE
27140 ALQCD2(I,2) = Q2
27141 endif
27142 ALQCD2(I,1) = PARMDL(148)
27143 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27144 ALQCD2(I,3) = PARMDL(149)
27145 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27146 ALQCD2(I,4) = PARMDL(150)
27147 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27148
27149 ENDIF
27150
27151 END
27152
27153*$ CREATE PHO_DFWRAP.FOR
27154*COPY PHO_DFWRAP
27155CDECK ID>, PHO_DFWRAP
27156 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27157C**********************************************************************
27158C
27159C wrapper for diffraction dissociation in hadron-nucleus and
27160C nucleus-nucleus collisions with DPMJET
27161C
27162C input: MODE 1: transformation into CMS
27163C 2: transformation into Lab
27164C JM1/2 indices of old mother particles
27165C JM1/2N indices of new mother particles
27166C
27167C**********************************************************************
27168 IMPLICIT NONE
27169 SAVE
27170
27171 INTEGER MODE,JM1,JM2
27172
27173C input/output channels
27174 INTEGER LI,LO
27175 COMMON /POINOU/ LI,LO
27176C event debugging information
27177 INTEGER NMAXD
27178 PARAMETER (NMAXD=100)
27179 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27180 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27181 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27182 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27183C standard particle data interface
27184 INTEGER NMXHEP
27185 PARAMETER (NMXHEP=4000)
27186 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27187 DOUBLE PRECISION PHEP,VHEP
27188 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27189 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27190 & VHEP(4,NMXHEP)
27191C extension to standard particle data interface (PHOJET specific)
27192 INTEGER IMPART,IPHIST,ICOLOR
27193 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27194C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27195 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27196 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27197 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27198 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27199
27200 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27201 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27202
27203 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27204
27205C transformation into CMS
27206
27207 IF(MODE.EQ.1) THEN
27208
27209 JM1S = JM1
27210 JM2S = JM2
27211 NHEPS = NHEP
27212
27213 XM1 = PHEP(5,JM1)
27214 XM2 = PHEP(5,JM2)
27215
27216C boost into CMS
27217 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27218 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27219 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27220 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27221 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27222 ECMD = SQRT(SS)
27223 DO 10 I=1,4
27224 GAMBED(I) = P1(I)/ECMD
27225 10 CONTINUE
27226 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27227 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27228 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27229C rotation angles
27230 CODD = P1(3)/PTOT1
27231 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27232 COFD = 1.D0
27233 SIFD = 0.D0
27234 IF(PTOT1*SIDD.GT.1.D-5) THEN
27235 COFD = P1(1)/(SIDD*PTOT1)
27236 SIFD = P1(2)/(SIDD*PTOT1)
27237 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27238 COFD = COFD/ANORF
27239 SIFD = SIFD/ANORF
27240 ENDIF
27241
27242C initial particles in CMS
27243
27244 P1(1) = 0.D0
27245 P1(2) = 0.D0
27246 P1(3) = ECMD/2.D0*XPSUB
27247 P1(4) = P1(3)
27248
27249 P2(1) = 0.D0
27250 P2(2) = 0.D0
27251 P2(3) = -ECMD/2.D0*XTSUB
27252 P2(4) = -P2(3)
27253
27254 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27255
27256 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27257 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27258 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27259
27260 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27261 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27262 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27263
27264 JM1 = JM1N
27265 JM2 = JM2N
27266
27267C transformation into lab.
27268
27269 ELSE IF(MODE.EQ.2) THEN
27270
27271 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27272 & GAMBED(1),GAMBED(2),GAMBED(3))
27273
27274 JM1 = JM1S
27275 JM2 = JM2S
27276
27277C clean up after rejection
27278
27279 ELSE IF(MODE.EQ.-2) THEN
27280
27281 NHEP = NHEPS
27282
27283 JM1 = JM1S
27284 JM2 = JM2S
27285
27286 ELSE
27287
27288 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27289
27290 ENDIF
27291
27292 END
27293
27294*$ CREATE PHO_DIFDIS.FOR
27295*COPY PHO_DIFDIS
27296CDECK ID>, PHO_DIFDIS
27297 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27298 & MSOFT,MHARD,IREJ)
27299C***********************************************************************
27300C
27301C sampling of diffractive events of different kinds,
27302C (produced particles stored in /POEVT1/)
27303C
27304C input: IDIF1/2 diffractive process particle 1/2
27305C 0 elastic/quasi-elastic scattering
27306C 1 diffraction dissociation
27307C IMOTH1/2 index of mother particles in /POEVT1/
27308C SPROB suppression factor (survival probability) for
27309C resolved diffraction dissociation
27310C IMODE mode of operation
27311C 0 sampling of diffractive cut
27312C 1 sampling of enhanced cut
27313C 2 sampling of diffractive cut without
27314C scattering (needed for double-pomeron)
27315C -1 initialization
27316C -2 output of statistics
27317C
27318C output: MSOFT number of generated soft strings
27319C MHARD number of generated hard strings
27320C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27321C 0 quasi elastic scattering
27322C 1 low-mass diffractive dissociation
27323C 2 soft high-mass diffractive dissociation
27324C 3 hard resolved diffractive dissociation
27325C 4 hard direct diffractive dissociation
27326C IREJ rejection label
27327C 0 successful generation of partons
27328C 1 failure
27329C
27330C***********************************************************************
27331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27332 SAVE
27333
27334 PARAMETER ( EPS = 1.D-7,
27335 & DEPS = 1.D-10)
27336
27337C input/output channels
27338 INTEGER LI,LO
27339 COMMON /POINOU/ LI,LO
27340C event debugging information
27341 INTEGER NMAXD
27342 PARAMETER (NMAXD=100)
27343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27347C general process information
27348 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27349 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27350C internal rejection counters
27351 INTEGER NMXJ
27352 PARAMETER (NMXJ=60)
27353 CHARACTER*10 REJTIT
27354 INTEGER IFAIL
27355 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27356C global event kinematics and particle IDs
27357 INTEGER IFPAP,IFPAB
27358 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27359 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27360C c.m. kinematics of diffraction
27361 INTEGER NPOSD
27362 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27363 & SIDD,CODD,SIFD,COFD,PDCMS
27364 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27365 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27366C obsolete cut-off information
27367 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27368 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27369C some constants
27370 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27371 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27372 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27373C model switches and parameters
27374 CHARACTER*8 MDLNA
27375 INTEGER ISWMDL,IPAMDL
27376 DOUBLE PRECISION PARMDL
27377 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27378C Reggeon phenomenology parameters
27379 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27380 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27381 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27382 & ALREG,ALREGP,GR(2),B0REG(2),
27383 & GPPP,GPPR,B0PPP,B0PPR,
27384 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27385C parameters of 2x2 channel model
27386 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27387 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27388C table of particle indices for recursive PHOJET calls
27389 INTEGER MAXIPX
27390 PARAMETER ( MAXIPX = 100 )
27391 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27392 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27393 & IPOIX1,IPOIX2,IPOIX3
27394C standard particle data interface
27395 INTEGER NMXHEP
27396 PARAMETER (NMXHEP=4000)
27397 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27398 DOUBLE PRECISION PHEP,VHEP
27399 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27400 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27401 & VHEP(4,NMXHEP)
27402C extension to standard particle data interface (PHOJET specific)
27403 INTEGER IMPART,IPHIST,ICOLOR
27404 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27405C event weights and generated cross section
27406 INTEGER IPOWGC,ISWCUT,IVWGHT
27407 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27408 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27409 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27410
27411 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27412 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27413 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27414 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27415 & IDIR(2),IPROC(2)
27416
27417 IF(IMODE.EQ.-1) THEN
27418C initialization
27419 RETURN
27420 ELSE IF(IMODE.EQ.-2) THEN
27421C output of statistics
27422 RETURN
27423 ENDIF
27424
27425 IREJ = 0
27426C mass cuts
27427 PIMASS = 0.140D0
27428C debug output
27429 IF(IDEB(45).GE.10) THEN
27430 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27431 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27432 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27433 ENDIF
27434 IPAR(1) = IDIF1
27435 IPAR(2) = IDIF2
27436C save current status
27437 MSOFT = 0
27438 MHARD = 0
27439 KHPOMS = KHPOM
27440 KSPOMS = KSPOM
27441 KSREGS = KSREG
27442 KHDIRS = KHDIR
27443 IPOIS1 = IPOIX1
27444 IPOIS2 = IPOIX2
27445 IPOIS3 = IPOIX3
27446 JDA11 = JDAHEP(1,IMOTH1)
27447 JDA21 = JDAHEP(2,IMOTH1)
27448 JDA12 = JDAHEP(1,IMOTH2)
27449 JDA22 = JDAHEP(2,IMOTH2)
27450 ISTH1 = ISTHEP(IMOTH1)
27451 ISTH2 = ISTHEP(IMOTH2)
27452 NHEPS = NHEP
27453C get mother data
27454 NPOSD(1) = IMOTH1
27455 NPOSD(2) = IMOTH2
27456 DO 20 I=1,2
27457 IDPDG(I) = IDHEP(NPOSD(I))
27458 IDBAM(I) = IMPART(NPOSD(I))
27459 AMP(I) = PHO_PMASS(IDBAM(I),0)
27460 IF(IDPDG(I).EQ.22) THEN
27461 PMASSD(I) = 0.765D0
27462 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27463 ELSE
27464 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27465 PVIRTD(I) = 0.D0
27466 ENDIF
27467 20 CONTINUE
27468C get CM system
27469 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27470 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27471 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27472 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27473 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27474 ECMD = SQRT(SS)
27475 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27476 & 'PHO_DIFDIS: availabe energy',ECMD
27477C check total available energy
27478 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27479 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27480 & 'PHO_DIFDIS: ',
27481 & 'not enough energy for inelastic diffraction',
27482 & 'ECM, particle masses:',ECMD,AMP
27483 IFAIL(7) = IFAIL(7)+1
27484 IREJ = 1
27485 RETURN
27486 ENDIF
27487C boost into CMS
27488 DO 10 I=1,4
27489 GAMBED(I) = P1(I)/ECMD
27490 10 CONTINUE
27491 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27492 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27493 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27494C rotation angles
27495 CODD = P1(3)/PTOT1
27496 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27497 COFD = 1.D0
27498 SIFD = 0.D0
27499 IF(PTOT1*SIDD.GT.1.D-5) THEN
27500 COFD = P1(1)/(SIDD*PTOT1)
27501 SIFD = P1(2)/(SIDD*PTOT1)
27502 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27503 COFD = COFD/ANORF
27504 SIFD = SIFD/ANORF
27505 ENDIF
27506C initial particles in CMS
27507 PDCMS(1,1) = 0.D0
27508 PDCMS(2,1) = 0.D0
27509 PDCMS(3,1) = PTOT1
27510 PDCMS(4,1) = P1(4)
27511 PDCMS(1,2) = 0.D0
27512 PDCMS(2,2) = 0.D0
27513 PDCMS(3,2) = -PTOT1
27514 PDCMS(4,2) = ECMD-P1(4)
27515C get new CM momentum
27516 AM12 = PMASSD(1)**2
27517 AM22 = PMASSD(2)**2
27518 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27519
27520C coherence constraint (min/max diffractive mass allowed)
27521 IF(IMODE.EQ.2) THEN
27522 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27523 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27524 THRM2 = SQRT(1-PARMDL(72))*ECMD
27525 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27526 ELSE
27527 THRM1 = PARMDL(46)
27528 THRM2 = PARMDL(45)*ECMD
27529C check kinematic limits
27530 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27531 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27532 ENDIF
27533
27534C check energy vs. coherence constraints
27535 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27536 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27537
27538C no phase space available
27539 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27540 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27541 & 'PHO_DIFDIS: ',
27542 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27543 & 'side 1: min. mass, upper mass limit:',
27544 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27545 & 'side 2: min. mass, upper mass limit:',
27546 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27547 IFAIL(7) = IFAIL(7)+1
27548 IREJ = 1
27549 RETURN
27550 ENDIF
27551
27552 ITRY = 0
27553 ITRYM = 10
27554 IPARS1 = IPAR(1)
27555 IPARS2 = IPAR(2)
27556
27557C main rejection loop
27558C -------------------------------
27559 50 CONTINUE
27560 ITRY = ITRY+1
27561 IF(ITRY.GT.1) THEN
27562 IFAIL(13) = IFAIL(13)+1
27563 IF(ITRY.GE.ITRYM) THEN
27564 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27565 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27566 IFAIL(7) = IFAIL(7)+1
27567 IREJ = 1
27568 RETURN
27569 ENDIF
27570 ENDIF
27571 KSPOM = KSPOMS
27572 KHPOM = KHPOMS
27573 KHDIR = KHDIRS
27574 KSREG = KSREGS
27575 IPAR(1) = IPARS1
27576 IPAR(2) = IPARS2
27577C reset mother-daugther relations
27578 NHEP = NHEPS
27579 JDAHEP(1,IMOTH1) = JDA11
27580 JDAHEP(2,IMOTH1) = JDA21
27581 JDAHEP(1,IMOTH2) = JDA12
27582 JDAHEP(2,IMOTH2) = JDA22
27583 ISTHEP(IMOTH1) = ISTH1
27584 ISTHEP(IMOTH2) = ISTH2
27585 IPOIX1 = IPOIS1
27586 IPOIX2 = IPOIS2
27587 IPOIX3 = IPOIS3
27588C
27589 NSLP = 0
27590 NCOR = 0
27591 55 CONTINUE
27592
27593C calculation of kinematics
27594 DO 100 I=1,2
27595C sampling of masses
27596 IRPDG(I) = 0
27597 IRBAM(I) = 0
27598 IFL1P(I) = IDPDG(I)
27599 IFL2P(I) = IDBAM(I)
27600 IVEC(I) = 0
27601 IDIR(I) = 0
27602 ISAM(I) = 0
27603 JSAM(I) = 0
27604 KSAM(I) = 0
27605 IF(IPAR(I).EQ.0) THEN
27606C vector meson dominance assumed
27607 XMASS(I) = AMP(I)
27608 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27609C diffraction dissociation
27610 ELSE IF(IPAR(I).EQ.1) THEN
27611 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27612 PREF2 = PMASSD(I)**2
27613 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27614 ELSE
27615 WRITE(LO,'(/1X,A,2I3)')
27616 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27617 CALL PHO_ABORT
27618 ENDIF
27619 100 CONTINUE
27620
27621C sampling of momentum transfer
27622 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27623 & THRM2,TT,SLWGHT,IREJ)
27624 IF(IREJ.NE.0) THEN
27625 NSLP=NSLP+1
27626 IF(NSLP.LT.100) GOTO 55
27627 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27628 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27629 IREJ = 5
27630 RETURN
27631 ENDIF
27632
27633C correct for t-M^2 correlation in diffraction
27634 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27635 NCOR=NCOR+1
27636 IF(NCOR.LT.100) GOTO 55
27637 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27638 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27639 IREJ = 5
27640 RETURN
27641 ENDIF
27642
27643C debug output
27644 IF(IDEB(45).GE.5) THEN
27645 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27646 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27647 ENDIF
27648C not double pomeron scattering
27649 IF(IMODE.NE.2) THEN
27650C sample diffractive interaction processes
27651 DO 120 I=1,2
27652 IF(IPAR(I).NE.0) THEN
27653C find particle combination
27654 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27655 IP = 2
27656 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27657 IP = 3
27658 ELSE IF(IDPDG(I).EQ.990) THEN
27659 IP = 4
27660 ELSE
27661 IP = I+1
27662 ENDIF
27663C sample dissociation process
27664 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27665 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27666 & KSAM(I),IDIR(I))
27667 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27668C store process label
27669 IF(IDIR(I).GT.0) THEN
27670 IPAR(I) = 4
27671 ELSE IF(KSAM(I).GT.0) THEN
27672 IPAR(I) = 3
27673 ELSE IF(ISAM(I).GT.0) THEN
27674 IPAR(I) = 2
27675 ELSE
27676 IPAR(I) = 1
27677C mass fine correction
27678 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27679 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27680 XMASS(I) = XMNEW
27681 ENDIF
27682 ELSE
27683C diffractive pomeron-hadron interaction
27684 IPAR(I) = 10+IPROC(I)
27685 ENDIF
27686C debug output
27687 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27688 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27689 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27690 ENDIF
27691 120 CONTINUE
27692 ENDIF
27693C actualize debug information
27694 IF(IMODE.EQ.1) THEN
27695 IDIFR1 = IPAR(1)
27696 IDIFR2 = IPAR(2)
27697 ENDIF
27698C calculate new momenta in CMS
27699 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27700 IF(IREJ.NE.0) GOTO 50
27701 DO 130 I=1,4
27702 PP(I,1) = P1(I)
27703 PP(I,2) = P2(I)
27704 130 CONTINUE
27705
27706C comment line for diffraction
27707 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27708 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27709C write diffractive strings/particles
27710 DO 200 I=1,2
27711 I1 = I
27712 I2 = 3-I1
27713 DO K=1,4
27714 PD1(K) = PP(K,I1)
27715 PD2(K) = PP(K,I2)
27716 ENDDO
27717 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27718 PP(7,I1) = TT
27719 IGEN = IPHIST(2,NPOSD(I1))
27720 if(IGEN.eq.0) IGEN = -I1*10
27721 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27722 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27723 IF(IREJ.NE.0) THEN
27724 IFAIL(7+I) = IFAIL(7+I)+1
27725 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27726 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27727 & I,IPAR(I),XMASS(I)
27728 GOTO 50
27729 ENDIF
27730 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27731 200 CONTINUE
27732C double-pomeron scattering?
27733 IF(IMODE.EQ.2) GOTO 150
27734
27735C diffractive final states
27736 DO 300 I=1,2
27737 110 CONTINUE
27738 IF(IPAR(I).EQ.0) THEN
27739C vector meson production
27740 IF(IDPDG(I).EQ.22) THEN
27741 IF(ISWMDL(21).GE.0) THEN
27742 ISP = IPAMDL(3)
27743 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27744 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27745 ENDIF
27746C hadronic state of multi-pomeron coupling
27747 ELSE IF(IDPDG(I).EQ.990) THEN
27748 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27749 ENDIF
27750 ELSE
27751 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27752 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27753 IF(IDIR(I).GT.0) THEN
27754 IPAR(I) = 4
27755 ELSE IF(KSAM(I).GT.0) THEN
27756 IPAR(I) = 3
27757 ELSE IF(ISAM(I).GT.0) THEN
27758 IPAR(I) = 2
27759 ELSE
27760 IPAR(I) = 1
27761 ENDIF
27762 ELSE
27763 IPAR(I) = 10+IPROC(I)
27764 ENDIF
27765 IPHIST(I,ICPOS) = IPAR(I)
27766C update debug informantion
27767 KSPOM = ISAM(I)
27768 KSREG = JSAM(I)
27769 KHPOM = KSAM(I)
27770 KHDIR = IDIR(I)
27771 IDIFR1 = IPAR(1)
27772 IDIFR2 = IPAR(2)
27773 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27774
27775C resonance decay, pi+pi- background
27776 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27777 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27778 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27779 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27780 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27781 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27782C decay
27783 IF(IDPDG(I).EQ.22) THEN
27784 IPHIST(2,IPOS) = 3
27785 IF(ISWMDL(21).GE.0) THEN
27786 ISP = IPAMDL(3)
27787 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27788 CALL PHO_SDECAY(IPOS,ISP,2)
27789 ENDIF
27790 ELSE
27791 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27792 ENDIF
27793 IREJ = 0
27794 ELSE
27795
27796C particle-pomeron scattering
27797 IF(IPAR(I).LE.4) THEN
27798C non-diffractive particle-pomeron scattering
27799 IGEN = IPHIST(2,NPOSD(I))
27800 if(IGEN.eq.0) then
27801 if(I.eq.1) then
27802 IGEN = 5
27803 else
27804 IGEN = 6
27805 endif
27806 endif
27807 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27808 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27809 ELSE
27810C diffractive particle-pomeron scattering
27811 IPOIX2 = IPOIX2+1
27812 IPORES(IPOIX2) = IPROC(I)
27813 IPOPOS(1,IPOIX2) = IPOSP(1,I)
27814 IPOPOS(2,IPOIX2) = IPOSP(2,I)
27815 ENDIF
27816 ENDIF
27817 ENDIF
27818
27819C rejection?
27820 IF(IREJ.NE.0) THEN
27821 IFAIL(20+I) = IFAIL(20+I)+1
27822 IF(IPAR(I).GT.1) THEN
27823 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27824 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27825 IF(IDIR(I).GT.0) THEN
27826 IDIR(I) = 0
27827 ELSE IF(KSAM(I).GT.0) THEN
27828 KSAM(I) = KSAM(I)-1
27829 ELSE IF(ISAM(I).GT.0) THEN
27830 ISAM(I) = ISAM(I)-1
27831 ENDIF
27832 GOTO 110
27833 ELSE
27834 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27835 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27836 & I,IPAR(I),XMASS(I)
27837 GOTO 50
27838 ENDIF
27839 ENDIF
27840 300 CONTINUE
27841
27842 IDIF1 = IPAR(1)
27843 IDIF2 = IPAR(2)
27844C update debug information
27845 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27846 KSREG = KSREGS+JSAM(1)+JSAM(2)
27847 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27848 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27849
27850 150 CONTINUE
27851
27852C debug output
27853 IF(IDEB(45).GE.10) THEN
27854 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27855 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27856 & IPAR,NPOSD,MSOFT,MHARD,IMODE
27857 ENDIF
27858 IF(IDEB(45).GE.15) THEN
27859 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27860 & '------------------------------'
27861 CALL PHO_PREVNT(0)
27862 ENDIF
27863
27864 END
27865
27866*$ CREATE PHO_DIFPRO.FOR
27867*COPY PHO_DIFPRO
27868CDECK ID>, PHO_DIFPRO
27869 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27870 & IPROC,ISAM,JSAM,KSAM,IDIR)
27871C*********************************************************************
27872C
27873C sampling of diffraction dissociation process
27874C
27875C input: IP particle combination
27876C ICUT user imposed limitations
27877C ID1/2 PDG particle code of scattering particles
27878C XMASS diffractively produced mass (GeV)
27879C P2V1/2 virtuality of scattering particles (Gev**2)
27880C SPROB suppression factor for resolved single and
27881C double diffraction dissociation
27882C
27883C output: IRPOC process ID
27884C ISAM number of cut pomerons (soft)
27885C JSAM number of cut reggeons
27886C KSAM number of cut pomerons (hard)
27887C IDIR direct hard interaction
27888C
27889C*********************************************************************
27890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27891 SAVE
27892
27893C input/output channels
27894 INTEGER LI,LO
27895 COMMON /POINOU/ LI,LO
27896C event debugging information
27897 INTEGER NMAXD
27898 PARAMETER (NMAXD=100)
27899 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27900 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27901 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27902 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27903C general process information
27904 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27905 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27906C model switches and parameters
27907 CHARACTER*8 MDLNA
27908 INTEGER ISWMDL,IPAMDL
27909 DOUBLE PRECISION PARMDL
27910 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27911C energy-interpolation table
27912 INTEGER IEETA2
27913 PARAMETER ( IEETA2 = 20 )
27914 INTEGER ISIMAX
27915 DOUBLE PRECISION SIGTAB,SIGECM
27916 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27917
27918 ISAM = 0
27919 JSAM = 0
27920 KSAM = 0
27921 IDIR = 0
27922
27923 IF(XMASS.GT.3.D0) THEN
27924C rapidity gap survival probability
27925 SPRO = 1.D0
27926 IF(ISWMDL(28).GE.1) SPRO = SPROB
27927C sample interaction
27928 IPROC = 0
27929 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27930 ELSE
27931 IPROC = 1
27932 ENDIF
27933 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27934C non-diffractive hadron-pomeron interaction
27935 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27936C option for suppression of multiple interaction
27937 IF(ICUT.EQ.0) THEN
27938 IPROC = 1
27939 IF(ISAM+KSAM+IDIR.GT.0) THEN
27940 ISAM = 1
27941 JSAM = 0
27942 ELSE
27943 JSAM = 1
27944 ENDIF
27945 KSAM = 0
27946 IDIR = 0
27947 ELSE IF(ICUT.EQ.1) THEN
27948 IF(IDIR.GT.0) THEN
27949 ELSE IF(KSAM.GT.0) THEN
27950 KSAM = 1
27951 ISAM = 0
27952 JSAM = 0
27953 ELSE IF(ISAM.GT.0) THEN
27954 ISAM = 1
27955 JSAM = 0
27956 ELSE
27957 JSAM = 1
27958 ENDIF
27959 ELSE IF(ICUT.EQ.2) THEN
27960 KSAM = MIN(KSAM,1)
27961 ELSE IF(ICUT.EQ.3) THEN
27962 ISAM = MIN(ISAM,1)
27963 ENDIF
27964 ENDIF
27965 END
27966
27967*$ CREATE PHO_DIFPAR.FOR
27968*COPY PHO_DIFPAR
27969CDECK ID>, PHO_DIFPAR
27970 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27971 & IPOSH1,IPOSH2,IMODE,IREJ)
27972C***********************************************************************
27973C
27974C perform string construction for diffraction dissociation
27975C
27976C input: IMOTH1,2 index of mother particles in POEVT1
27977C IGENM production process of mother particles
27978C IFL1,IFL2 particle numbers
27979C (IDPDG,IDBAM for quasi-elas. hadron)
27980C IPAR 0 quasi-elasic scattering
27981C 1 single string configuration
27982C 2 two string configuration
27983C P1 massive 4 momentum of first
27984C P1(6) virtuality/squ.mass of particle (GeV**2)
27985C P1(7) virtuality of Pomeron (neg, GeV**2)
27986C P2 massive 4 momentum of second particle
27987C IMODE 1 diffraction dissociation
27988C 2 double-pomeron scattering
27989C
27990C output: IPOSH1,2 index of the particles in /POEVT1/
27991C IREJ 0 successful string construction
27992C 1 no string construction possible
27993C
27994C***********************************************************************
27995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27996 SAVE
27997
27998 DIMENSION P1(7),P2(7)
27999
28000 PARAMETER ( EPS = 1.D-7,
28001 & DEPS = 1.D-10)
28002
28003C input/output channels
28004 INTEGER LI,LO
28005 COMMON /POINOU/ LI,LO
28006C event debugging information
28007 INTEGER NMAXD
28008 PARAMETER (NMAXD=100)
28009 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28010 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28011 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28012 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28013C internal rejection counters
28014 INTEGER NMXJ
28015 PARAMETER (NMXJ=60)
28016 CHARACTER*10 REJTIT
28017 INTEGER IFAIL
28018 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28019C c.m. kinematics of diffraction
28020 INTEGER NPOSD
28021 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28022 & SIDD,CODD,SIFD,COFD,PDCMS
28023 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28024 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28025C model switches and parameters
28026 CHARACTER*8 MDLNA
28027 INTEGER ISWMDL,IPAMDL
28028 DOUBLE PRECISION PARMDL
28029 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28030C some constants
28031 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28032 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28033 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28034C standard particle data interface
28035 INTEGER NMXHEP
28036 PARAMETER (NMXHEP=4000)
28037 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28038 DOUBLE PRECISION PHEP,VHEP
28039 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28040 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28041 & VHEP(4,NMXHEP)
28042C extension to standard particle data interface (PHOJET specific)
28043 INTEGER IMPART,IPHIST,ICOLOR
28044 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28045
28046 DIMENSION PCH1(2,4)
28047 data IC1 /0/
28048 data IC2 /0/
28049
28050 IREJ = 0
28051 ILTR1 = NHEP+1
28052 IGEN = IGENM
28053 if(IGENM.le.-10) IGEN = 0
28054
28055C elastic part
28056 IF(IPAR.EQ.0) THEN
28057 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28058 if(IGEN.eq.0) IGEN = 3
28059C pi+/pi- isotropic background
28060 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28061 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28062 CALL PHO_SDECAY(IPOSH1,0,-2)
28063 ELSE
28064 if(IGEN.eq.0) then
28065 IGEN = 2
28066 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28067 endif
28068C registration of particle or resonance
28069 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28070 & P1(4),0,IGEN,0,0,IPOSH1,1)
28071 ENDIF
28072
28073C diffraction dissociation
28074 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28075C calculation of resulting particle momenta
28076 IF(IMOTH1.EQ.NPOSD(1)) THEN
28077 K = 2
28078 ELSE
28079 K = 1
28080 ENDIF
28081 DO 100 I=1,4
28082 PCH1(2,I) = PDCMS(I,K)-P2(I)
28083 PCH1(1,I) = P1(I)-PCH1(2,I)
28084 100 CONTINUE
28085
28086C registration
28087 if(IMODE.LT.2) then
28088 if(IGEN.eq.0) IGEN = -IGENM/10+4
28089 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28090 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28091 else
28092 if(IGEN.eq.0) IGEN = 4
28093 endif
28094 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28095 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28096
28097C invalid IPAR
28098 ELSE
28099 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28100 CALL PHO_ABORT
28101 ENDIF
28102
28103C back transformation
28104 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28105 & GAMBED(1),GAMBED(2),GAMBED(3))
28106
28107 END
28108
28109*$ CREATE PHO_QELAST.FOR
28110*COPY PHO_QELAST
28111CDECK ID>, PHO_QELAST
28112 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28113C**********************************************************************
28114C
28115C sampling of quasi elastic processes
28116C
28117C input: IPROC 2 purely elastic scattering
28118C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28119C IPROC 4 double pomeron scattering
28120C IPROC -1 initialization
28121C IPROC -2 output of statistics
28122C JM1/2 index of initial particle 1/2
28123C
28124C output: initial and final particles in /POEVT1/ involving
28125C polarized resonances in /POEVT1/ and decay
28126C products
28127C
28128C IREJ 0 successful
28129C 1 failure
28130C 50 user rejection
28131C
28132C**********************************************************************
28133 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28134 SAVE
28135
28136 PARAMETER ( NTAB = 20,
28137 & EPS = 1.D-10,
28138 & PIMASS = 0.13D0,
28139 & DEPS = 1.D-10)
28140
28141C input/output channels
28142 INTEGER LI,LO
28143 COMMON /POINOU/ LI,LO
28144C event debugging information
28145 INTEGER NMAXD
28146 PARAMETER (NMAXD=100)
28147 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28148 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28149 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28150 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28151C global event kinematics and particle IDs
28152 INTEGER IFPAP,IFPAB
28153 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28154 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28155C c.m. kinematics of diffraction
28156 INTEGER NPOSD
28157 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28158 & SIDD,CODD,SIFD,COFD,PDCMS
28159 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28160 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28161C model switches and parameters
28162 CHARACTER*8 MDLNA
28163 INTEGER ISWMDL,IPAMDL
28164 DOUBLE PRECISION PARMDL
28165 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28166C some constants
28167 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28168 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28169 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28170C cross sections
28171 INTEGER IPFIL,IFAFIL,IFBFIL
28172 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28173 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28174 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28175 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28176 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28177 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28178 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28179 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28180 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28181 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28182 & IPFIL,IFAFIL,IFBFIL
28183C standard particle data interface
28184 INTEGER NMXHEP
28185 PARAMETER (NMXHEP=4000)
28186 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28187 DOUBLE PRECISION PHEP,VHEP
28188 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28189 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28190 & VHEP(4,NMXHEP)
28191C extension to standard particle data interface (PHOJET specific)
28192 INTEGER IMPART,IPHIST,ICOLOR
28193 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28194
28195 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28196 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28197 DIMENSION IFL(2),IDPRO(4)
28198 character*15 pho_pname
28199 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28200 DIMENSION ISAMVM(4,4)
28201 DATA IDPRO / 113,223,333,92 /
28202 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28203 & 'pi+pi- ' /
28204 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28205 & 'pi+pi- ' /
28206
28207C sampling of elastic/quasi-elastic processes
28208 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28209 IREJ = 0
28210 NPOSD(1) = JM1
28211 NPOSD(2) = JM2
28212 DO 55 I=1,2
28213 PMI(I) = PHEP(5,NPOSD(I))
28214 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28215 55 CONTINUE
28216C get CM system
28217 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28218 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28219 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28220 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28221 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28222 ECMD = SQRT(SS)
28223
28224 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28225 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28226 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28227 & ECMD,PMI
28228 IREJ = 5
28229 RETURN
28230 ENDIF
28231
28232 DO 60 I=1,4
28233 GAMBED(I) = PK1(I)/ECMD
28234 60 CONTINUE
28235 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28236 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28237 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28238C rotation angles
28239 CODD = PK1(3)/PTOT1
28240 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28241 COFD = 1.D0
28242 SIFD = 0.D0
28243 IF(PTOT1*SIDD.GT.1.D-5) THEN
28244 COFD = PK1(1)/(SIDD*PTOT1)
28245 SIFD = PK1(2)/(SIDD*PTOT1)
28246 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28247 COFD = COFD/ANORF
28248 SIFD = SIFD/ANORF
28249 ENDIF
28250C get CM momentum
28251 AM12 = PMI(1)**2
28252 AM22 = PMI(2)**2
28253 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28254
28255C production process of mother particles
28256 IGEN = IPHIST(2,NPOSD(1))
28257 if(IGEN.eq.0) IGEN = IPROC
28258
28259 ICALL = ICALL + 1
28260C main rejection label
28261 50 CONTINUE
28262C determine process and final particles
28263 IFL(1) = IDHEP(NPOSD(1))
28264 IFL(2) = IDHEP(NPOSD(2))
28265 IF(IPROC.EQ.3) THEN
28266 ITRY = 0
28267 100 CONTINUE
28268 ITRY = ITRY+1
28269 IF(ITRY.GT.50) THEN
28270 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28271 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28272 & ITRY,ECMD
28273 IREJ = 5
28274 RETURN
28275 ENDIF
28276 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28277 DO 110 I=1,4
28278 DO 120 J=1,4
28279 XI = XI-SIGVM(I,J)
28280 IF(XI.LE.0.D0) GOTO 130
28281 120 CONTINUE
28282 110 CONTINUE
28283 130 CONTINUE
28284 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28285 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28286 ISAMVM(I,J) = ISAMVM(I,J)+1
28287 ISAMQE = ISAMQE+1
28288C sample new masses
28289 CALL PHO_SAMASS(IFL(1),RMASS(1))
28290 CALL PHO_SAMASS(IFL(2),RMASS(2))
28291 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28292 ELSE IF(IPROC.EQ.2) THEN
28293 I = 0
28294 J = 0
28295 ISAMEL = ISAMEL+1
28296 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28297 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28298 ELSE
28299 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28300 CALL PHO_ABORT
28301 ENDIF
28302C sample momentum transfer
28303 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28304 & SLWGHT,IREJ)
28305 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28306 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28307C calculate new momenta
28308 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28309 IF(IREJ.NE.0) GOTO 50
28310 DO K=1,4
28311 P(K,1) = PK1(K)
28312 P(K,2) = PK2(K)
28313 ENDDO
28314C comment line for elastic/quasi-elastic scattering
28315 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28316 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28317
28318 I1 = NHEP+1
28319C fill /POEVT1/
28320 DO 200 I=1,2
28321 K = 3-I
28322 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28323C pi+/pi- isotropic background
28324 IGEN = 3
28325 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28326 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28327 ICOLOR(I,ICPOS) = IPOS
28328 CALL PHO_SDECAY(IPOS,0,-2)
28329 ELSE
28330C registration
28331 IGEN = 2
28332 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28333 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28334 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28335 ICOLOR(I,ICPOS) = IPOS
28336 ENDIF
28337 200 CONTINUE
28338 I2 = NHEP
28339C search for vector mesons
28340 DO 300 I=I1,I2
28341C decay according to polarization
28342 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28343 ISP = IPAMDL(3)
28344 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28345 CALL PHO_SDECAY(I,ISP,2)
28346 ENDIF
28347 300 CONTINUE
28348 I2 = NHEP
28349C back transformation
28350 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28351 & GAMBED(2),GAMBED(3))
28352
28353C initialization of tables
28354 ELSE IF(IPROC.EQ.-1) THEN
28355 DO 10 I=1,4
28356 DO 20 J=1,4
28357 ISAMVM(I,J) = 0
28358 20 CONTINUE
28359 10 CONTINUE
28360 ISAMEL = 0
28361 ISAMQE = 0
28362 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28363 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28364 CALL PHO_SAMASS(-1,RMASS(1))
28365 ICALL = 0
28366
28367C output of statistics
28368 ELSE IF(IPROC.EQ.-2) THEN
28369 IF(ICALL.LT.10) RETURN
28370 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28371 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28372 & '---------------------------------------------------'
28373 WRITE(LO,'(1X,A,I10)')
28374 & 'sampled elastic processes:',ISAMEL
28375 WRITE(LO,'(1X,A,I10)')
28376 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28377 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28378 DO 30 I=1,4
28379 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28380 30 CONTINUE
28381 CALL PHO_SAMASS(-2,RMASS(1))
28382 ELSE
28383 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28384 & 'unknown process ID',IPROC
28385 CALL PHO_ABORT
28386 ENDIF
28387
28388 END
28389
28390*$ CREATE PHO_CDIFF.FOR
28391*COPY PHO_CDIFF
28392CDECK ID>, PHO_CDIFF
28393 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28394C**********************************************************************
28395C
28396C preparation of /POEVT1/ for double-pomeron scattering
28397C
28398C input: IMOTH1/2 index of mother particles in /POEVT1/
28399C
28400C IMODE 1 sampling of pomeron-pomeron scattering
28401C -1 initialization
28402C -2 output of statistics
28403C
28404C output: MSOFT number of generated soft strings
28405C MHARD number of generated hard strings
28406C IREJ 0 accepted
28407C 1 rejected
28408C 50 user rejection
28409C
28410C**********************************************************************
28411 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28412 SAVE
28413
28414 PARAMETER ( EPS = 1.D-10,
28415 & DEPS = 1.D-10)
28416
28417C input/output channels
28418 INTEGER LI,LO
28419 COMMON /POINOU/ LI,LO
28420C event debugging information
28421 INTEGER NMAXD
28422 PARAMETER (NMAXD=100)
28423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28427C internal rejection counters
28428 INTEGER NMXJ
28429 PARAMETER (NMXJ=60)
28430 CHARACTER*10 REJTIT
28431 INTEGER IFAIL
28432 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28433C model switches and parameters
28434 CHARACTER*8 MDLNA
28435 INTEGER ISWMDL,IPAMDL
28436 DOUBLE PRECISION PARMDL
28437 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28438C general process information
28439 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28440 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28441C Reggeon phenomenology parameters
28442 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28443 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28444 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28445 & ALREG,ALREGP,GR(2),B0REG(2),
28446 & GPPP,GPPR,B0PPP,B0PPR,
28447 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28448C parameters of 2x2 channel model
28449 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28450 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28451C some constants
28452 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28453 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28454 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28455C energy-interpolation table
28456 INTEGER IEETA2
28457 PARAMETER ( IEETA2 = 20 )
28458 INTEGER ISIMAX
28459 DOUBLE PRECISION SIGTAB,SIGECM
28460 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28461C table of particle indices for recursive PHOJET calls
28462 INTEGER MAXIPX
28463 PARAMETER ( MAXIPX = 100 )
28464 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28465 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28466 & IPOIX1,IPOIX2,IPOIX3
28467C standard particle data interface
28468 INTEGER NMXHEP
28469 PARAMETER (NMXHEP=4000)
28470 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28471 DOUBLE PRECISION PHEP,VHEP
28472 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28473 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28474 & VHEP(4,NMXHEP)
28475C extension to standard particle data interface (PHOJET specific)
28476 INTEGER IMPART,IPHIST,ICOLOR
28477 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28478
28479 DIMENSION PD(4)
28480
28481 if(IMODE.ne.1) return
28482
28483 IREJ = 0
28484 IP = 4
28485C select first diffraction
28486 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28487 IPAR1 = 1
28488 IPAR2 = 0
28489 ELSE
28490 IPAR1 = 0
28491 IPAR2 = 1
28492 ENDIF
28493 ITRY2 = 0
28494 ITRYM = 1000
28495
28496C save current status
28497 MSOFT = 0
28498 MHARD = 0
28499 KHPOMS = KHPOM
28500 KSPOMS = KSPOM
28501 KSREGS = KSREG
28502 KHDIRS = KHDIR
28503 IPOIS1 = IPOIX1
28504 IPOIS2 = IPOIX2
28505 IPOIS3 = IPOIX3
28506 JDA11 = JDAHEP(1,IMOTH1)
28507 JDA21 = JDAHEP(2,IMOTH1)
28508 JDA12 = JDAHEP(1,IMOTH2)
28509 JDA22 = JDAHEP(2,IMOTH2)
28510 ISTH1 = ISTHEP(IMOTH1)
28511 ISTH2 = ISTHEP(IMOTH2)
28512 NHEPS = NHEP
28513
28514C find mother particle production process
28515 IGEN = IPHIST(2,IMOTH1)
28516 if(IGEN.eq.0) IGEN = 4
28517
28518C main generation loop
28519 60 CONTINUE
28520
28521 KSPOM = KSPOMS
28522 KHPOM = KHPOMS
28523 KHDIR = KHDIRS
28524 KSREG = KSREGS
28525 I1 = IPAR1
28526 I2 = IPAR2
28527C reset mother-daugther relations
28528 NHEP = NHEPS
28529 JDAHEP(1,IMOTH1) = JDA11
28530 JDAHEP(2,IMOTH1) = JDA21
28531 JDAHEP(1,IMOTH2) = JDA12
28532 JDAHEP(2,IMOTH2) = JDA22
28533 ISTHEP(IMOTH1) = ISTH1
28534 ISTHEP(IMOTH2) = ISTH2
28535 IPOIX1 = IPOIS1
28536 IPOIX2 = IPOIS2
28537 IPOIX3 = IPOIS3
28538C rejection counter
28539 ITRY2 = ITRY2+1
28540 IF(ITRY2.GT.1) THEN
28541 IFAIL(39) = IFAIL(39)+1
28542 IF(ITRY2.GE.ITRYM) GOTO 50
28543 ENDIF
28544C generate two diffractive events
28545 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28546 IF(IREJ.NE.0) GOTO 50
28547 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28548 IF(IREJ.NE.0) GOTO 50
28549C mass of pomeron-pomeron system
28550 DO 100 I2 = NHEP,1,-1
28551 IF(IDHEP(I2).EQ.990) GOTO 110
28552 100 CONTINUE
28553 110 CONTINUE
28554 DO 120 I1 = I2-1,1,-1
28555 IF(IDHEP(I1).EQ.990) GOTO 130
28556 120 CONTINUE
28557 130 CONTINUE
28558 DO 140 I=1,4
28559 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28560 140 CONTINUE
28561 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28562 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28563 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28564 IF(XMASS.LT.0.1D0) GOTO 60
28565 XMASS = SQRT(XMASS)
28566 IF(XMASS.LT.PARMDL(71)) GOTO 60
28567
28568C sample pomeron-pomeron interaction process
28569 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28570 & IPROC,ISAM,JSAM,KSAM,IDIR)
28571
28572C non-diffractive pomeron-pomeron interactions
28573 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28574 200 CONTINUE
28575 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28576C debug output
28577 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28578 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28579 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28580C store debug information
28581 IF(IDIR.GT.0) THEN
28582 IPAR = 4
28583 ELSE IF(KSAM.GT.0) THEN
28584 IPAR = 3
28585 ELSE IF(ISAM.GT.0) THEN
28586 IPAR = 2
28587 ELSE
28588 IPAR = 1
28589 ENDIF
28590 IDDPOM = IPAR
28591 IF(ISAM+JSAM.GT.0) KSDPO = 1
28592 IF(KSAM+IDIR.GT.0) KHDPO = 1
28593 KSPOM = ISAM
28594 KSREG = JSAM
28595 KHPOM = KSAM
28596 KHDIR = IDIR
28597 KSTRG = 0
28598 KSLOO = 0
28599C generate pomeron-pomeron interaction
28600 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28601 IF(IREJ.NE.0) THEN
28602 IFAIL(3) = IFAIL(3)+1
28603 IF(IPAR.GT.1) THEN
28604 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28605 IF(IDIR.GT.0) THEN
28606 IFAIL(10) = IFAIL(10)+1
28607 IDIR = 0
28608 ELSE IF(KSAM.GT.0) THEN
28609 KSAM = KSAM-1
28610 ELSE IF(ISAM.GT.0) THEN
28611 ISAM = ISAM-1
28612 ENDIF
28613 GOTO 200
28614 ELSE
28615 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28616 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28617 & I,IPAR,XMASS
28618 GOTO 50
28619 ENDIF
28620 ENDIF
28621
28622C diffractive pomeron-pomeron interactions
28623 ELSE
28624 IPOIX2 = IPOIX2+1
28625 IPORES(IPOIX2) = IPROC
28626 IPOPOS(1,IPOIX2) = I1
28627 IPOPOS(2,IPOIX2) = I2
28628 IPAR = 10+IPROC
28629 IDDPOM = IPAR
28630 ENDIF
28631
28632C update debug information
28633 KSPOM = KSPOMS+ISAM
28634 KSREG = KSREGS+JSAM
28635 KHPOM = KHPOMS+KSAM
28636 KHDIR = KHDIRS+IDIR
28637C comment line for central diffraction
28638 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28639 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28640 PHEP(5,IPOS) = XMASS
28641C debug output
28642 IF(IDEB(59).GE.15) THEN
28643 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28644 & '-----------------------------'
28645 CALL PHO_PREVNT(0)
28646 ENDIF
28647 RETURN
28648
28649C treatment of rejection
28650 50 CONTINUE
28651 IREJ = 1
28652 IFAIL(40) = IFAIL(40)+1
28653 IF(IDEB(59).GE.3) THEN
28654 WRITE(LO,'(1X,A)')
28655 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28656 IF(IDEB(59).GE.10) THEN
28657 CALL PHO_PREVNT(0)
28658 ELSE
28659 CALL PHO_PREVNT(-1)
28660 ENDIF
28661 ENDIF
28662
28663 END
28664
28665*$ CREATE PHO_SAMASS.FOR
28666*COPY PHO_SAMASS
28667CDECK ID>, PHO_SAMASS
28668 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28669C**********************************************************************
28670C
28671C resonance mass sampling of quasi elastic processes
28672C
28673C input: IFLA PDG number of particle
28674C IFLA -1 initialization
28675C IFLA -2 output of statistics
28676C
28677C output: RMASS particle mass (in GeV)
28678C
28679C**********************************************************************
28680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28681 SAVE
28682
28683 PARAMETER(EPS = 1.D-10 )
28684
28685C input/output channels
28686 INTEGER LI,LO
28687 COMMON /POINOU/ LI,LO
28688C event debugging information
28689 INTEGER NMAXD
28690 PARAMETER (NMAXD=100)
28691 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28692 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28693 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28694 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28695C model switches and parameters
28696 CHARACTER*8 MDLNA
28697 INTEGER ISWMDL,IPAMDL
28698 DOUBLE PRECISION PARMDL
28699 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28700C parameters of the "simple" Vector Dominance Model
28701 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28702 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28703
28704 PARAMETER(NTABM=50)
28705 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28706 DIMENSION SUM(4),ICALL(4)
28707
28708C*****************************************************************
28709C initialization of tables
28710 IF(IFLA.EQ.-1) THEN
28711C
28712 NSTEP = NTABM
28713 DO 102 I=1,4
28714 ICALL(I) = 0
28715 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28716 DO 105 K=1,NSTEP
28717 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28718 105 CONTINUE
28719 102 CONTINUE
28720C calculate table of dsig/dm
28721 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28722C output of table
28723 IF(IDEB(35).GE.1) THEN
28724 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28725 WRITE(LO,'(1X,A,/1X,A)')
28726 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28727 & ' -------------------------------------------------------'
28728 DO 106 K=1,NSTEP
28729 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28730 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28731 106 CONTINUE
28732 ENDIF
28733C make second table for sampling
28734 DO 109 I=1,4
28735 SUM(I) = 0.D0
28736 DO 108 K=2,NSTEP
28737 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28738 XMC(I,K) = SUM(I)
28739 108 CONTINUE
28740 109 CONTINUE
28741C normalization
28742 DO 118 K=1,NSTEP
28743 DO 119 I=1,4
28744 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28745 119 CONTINUE
28746 118 CONTINUE
28747 IF(IDEB(35).GE.10) THEN
28748 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28749 WRITE(LO,'(1X,A,/1X,A)')
28750 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28751 & ' -------------------------------------------------------'
28752 DO 120 K=1,NSTEP
28753 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28754 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28755 120 CONTINUE
28756 ENDIF
28757C
28758C**************************************************
28759C output of statistics
28760 ELSE IF(IFLA.EQ.-2) THEN
28761 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28762 & '----------------------'
28763 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
28764 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
28765C
28766C********************************************************
28767C sampling of RMASS
28768 ELSE
28769C quasi-elastic vector meson production
28770 IF(IFLA.EQ.113) THEN
28771 KP = 1
28772 ELSE IF(IFLA.EQ.223) THEN
28773 KP = 2
28774 ELSE IF(IFLA.EQ.333) THEN
28775 KP = 3
28776 ELSE IF(IFLA.EQ.92) THEN
28777 KP = 4
28778C quasi-elastic production of h*
28779 ELSE IF(IFLA.EQ.91) THEN
28780 RMASS = 0.35D0
28781 RETURN
28782C elastic hadron scattering
28783 ELSE
28784 RMASS = PHO_PMASS(IFLA,1)
28785 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28786 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28787 RETURN
28788 ENDIF
28789C
28790C sample mass of vector mesonsn / two-pi background
28791 XI = DT_RNDM(RMASS) + EPS
28792C binary search
28793 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28794 KMIN=1
28795 KMAX=NSTEP
28796 300 CONTINUE
28797 IF((KMAX-KMIN).EQ.1) GOTO 400
28798 KK=(KMAX+KMIN)/2
28799 IF(XI.LE.XMC(KP,KK)) THEN
28800 KMAX=KK
28801 ELSE
28802 KMIN=KK
28803 ENDIF
28804 GOTO 300
28805 400 CONTINUE
28806 ELSE
28807 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28808 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28809 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28810 CALL PHO_ABORT
28811 ENDIF
28812C fine interpolation
28813 RMASS = RMA(KP,KMIN)+
28814 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
28815 & (XMC(KP,KMAX)-XMC(KP,KMIN))
28816 & *(XI-XMC(KP,KMIN))
28817 IF(IDEB(35).GE.20) THEN
28818 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28819 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28820 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28821 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28822 & IFLA,RMASS
28823 ENDIF
28824 ICALL(KP) = ICALL(KP)+1
28825 ENDIF
28826 END
28827
28828*$ CREATE PHO_DSIGDM.FOR
28829*COPY PHO_DSIGDM
28830CDECK ID>, PHO_DSIGDM
28831 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28832C**********************************************************************
28833C
28834C differential cross section DSIG/DM of low mass enhancement
28835C
28836C input: RMA(4,NTABM) mass values
28837C output: XMA(4,NTABM) DSIG/DM of resonances
28838C 1 rho production
28839C 2 omega production
28840C 3 phi production
28841C 4 pi-pi continuum
28842C
28843C**********************************************************************
28844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28845 SAVE
28846
28847 PARAMETER ( EPS = 1.D-10 )
28848
28849 PARAMETER(NTABM=50)
28850 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28851
28852C input/output channels
28853 INTEGER LI,LO
28854 COMMON /POINOU/ LI,LO
28855C event debugging information
28856 INTEGER NMAXD
28857 PARAMETER (NMAXD=100)
28858 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28859 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28860 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28861 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28862C model switches and parameters
28863 CHARACTER*8 MDLNA
28864 INTEGER ISWMDL,IPAMDL
28865 DOUBLE PRECISION PARMDL
28866 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28867C parameters of the "simple" Vector Dominance Model
28868 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28869 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28870
28871 PIMASS = 0.135
28872C rho meson shape (mass dependent width)
28873 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28874 DO 100 I=1,NSTEP
28875 XMASS = RMA(1,I)
28876 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28877 GAMMA = GAMM(1)*(QQ/QRES)**3
28878 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28879 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28880 100 CONTINUE
28881C omega/phi meson (constant width)
28882 DO 200 K=2,3
28883 DO 300 I=1,NSTEP
28884 XMASS = RMA(K,I)
28885 XMA(K,I) = XMASS*GAMM(K)
28886 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28887 300 CONTINUE
28888 200 CONTINUE
28889C pi-pi continuum
28890 DO 400 I=1,NSTEP
28891 XMASS = RMA(4,I)
28892 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28893 400 CONTINUE
28894
28895 END
28896
28897*$ CREATE PHO_SDECAY.FOR
28898*COPY PHO_SDECAY
28899CDECK ID>, PHO_SDECAY
28900 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28901C**********************************************************************
28902C
28903C decay of single resonance of /POEVT1/:
28904C decay in helicity frame according to polarization, isotropic
28905C decay and decay with limited transverse phase space possible
28906C
28907C ATTENTION:
28908C reference to particle number of CPC has to exist
28909C
28910C input: NPOS position in /POEVT1/
28911C ISP 0 decay according to phase space
28912C 1 decay according to transversal polarization
28913C 2 decay according to longitudinal polarization
28914C 3 decay with limited phase space
28915C ILEV decay mode to use
28916C 1 strong only
28917C 2 strong and ew of tau, charm, and bottom
28918C 3 strong and electro-weak decays
28919C negative: remove mother resonance after decay
28920C
28921C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28922C
28923C**********************************************************************
28924 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28925 SAVE
28926
28927 PARAMETER ( EPS = 1.D-15,
28928 & DEPS = 1.D-10 )
28929
28930C input/output channels
28931 INTEGER LI,LO
28932 COMMON /POINOU/ LI,LO
28933C event debugging information
28934 INTEGER NMAXD
28935 PARAMETER (NMAXD=100)
28936 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28937 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28938 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28939 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28940C model switches and parameters
28941 CHARACTER*8 MDLNA
28942 INTEGER ISWMDL,IPAMDL
28943 DOUBLE PRECISION PARMDL
28944 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28945C some constants
28946 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28947 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28948 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28949C standard particle data interface
28950 INTEGER NMXHEP
28951 PARAMETER (NMXHEP=4000)
28952 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28953 DOUBLE PRECISION PHEP,VHEP
28954 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28955 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28956 & VHEP(4,NMXHEP)
28957C extension to standard particle data interface (PHOJET specific)
28958 INTEGER IMPART,IPHIST,ICOLOR
28959 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28960C general particle data
28961 double precision xm_list,tau_list,gam_list,
28962 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28963 & xm_bb82_list,xm_bb102_list
28964 integer ich3_list,iba3_list,iq_list,
28965 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
28966 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28967 & xm_psm2_list(6,6),xm_vem2_list(6,6),
28968 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28969 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28970 & ich3_list(300),iba3_list(300),iq_list(3,300),
28971 & id_psm_list(6,6),id_vem_list(6,6),
28972 & id_b8_list(6,6,6),id_b10_list(6,6,6)
28973C particle decay data
28974 double precision wg_sec_list
28975 integer idec_list,isec_list
28976 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28977 & isec_list(3,500)
28978C auxiliary data for three particle decay
28979 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28980 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28981
28982 DIMENSION WGHD(20),KCH(20),ID(3)
28983
28984 IMODE = ABS(ILEV)
28985 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28986 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28987
28988C comment entry
28989 IF(ISTHEP(NPOS).GT.11) RETURN
28990
28991C particle stable?
28992 IDcpc = IMPART(NPOS)
28993 IF(IDcpc.EQ.0) return
28994 IDabs = iabs(IDcpc)
28995 if(idec_list(1,IDabs).eq.0) return
28996
28997C different decay modi (times)
28998 IF(IMODE.EQ.1) THEN
28999 if(idec_list(1,IDabs).ne.1) return
29000 ELSE IF(IMODE.EQ.2) THEN
29001 if(idec_list(1,IDabs).gt.2) return
29002 ELSE IF(IMODE.EQ.3) THEN
29003 if(idec_list(1,IDabs).gt.3) return
29004 ELSE
29005 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29006 CALL PHO_ABORT
29007 ENDIF
29008
29009C decay products, check for mass limitations
29010 K = 0
29011 WGSUM = 0.D0
29012 AMIST = PHEP(5,NPOS)
29013 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29014 AMSUM = 0.D0
29015 DO 200 L=1,3
29016 ID(L) = isec_list(L,I)
29017 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29018 200 CONTINUE
29019 IF(AMSUM.LT.AMIST) THEN
29020 K = K+1
29021 WGHD(K) = wg_sec_list(I)
29022 KCH(K) = I
29023 ENDIF
29024 100 CONTINUE
29025 IF(K.EQ.0)THEN
29026 WRITE(LO,'(/1X,A,I6,3E12.4)')
29027 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29028 & NPOS,AMIST,AMSUM
29029 CALL PHO_PREVNT(0)
29030 RETURN
29031 ENDIF
29032
29033C sample new decay channel
29034 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29035 K = 0
29036 WGSUM = 0.D0
29037 500 CONTINUE
29038 K = K+1
29039 WGSUM = WGSUM+WGHD(K)
29040 IF(XI.GT.WGSUM) GOTO 500
29041 IK = KCH(K)
29042 ID(1) = isec_list(1,IK)
29043 ID(2) = isec_list(2,IK)
29044 ID(3) = isec_list(3,IK)
29045 if(IDcpc.lt.0) then
29046 ID(1) = ipho_anti(ID(1))
29047 ID(2) = ipho_anti(ID(2))
29048 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29049 endif
29050
29051C rotation
29052 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29053 CXS = PHEP(1,NPOS)/PTOT
29054 CYS = PHEP(2,NPOS)/PTOT
29055 CZS = PHEP(3,NPOS)/PTOT
29056C boost
29057 GBET = PTOT/AMIST
29058 GAM = PHEP(4,NPOS)/AMIST
29059
29060 IF(ID(3).EQ.0) THEN
29061C two particle decay
29062 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29063 ELSE
29064C three particle decay
29065 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29066 & pho_pmass(ID(3),0),ISP)
29067 ENDIF
29068
29069 IF(ILEV.LT.0) THEN
29070 IF(NHEP.NE.NPOS) THEN
29071 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29072 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29073 CALL PHO_ABORT
29074 ENDIF
29075 IMO1 = JMOHEP(1,NPOS)
29076 IMO2 = JMOHEP(2,NPOS)
29077 NHEP = NHEP-1
29078 ELSE
29079 IMO1 = NPOS
29080 IMO2 = 0
29081 ENDIF
29082 IPH1 = IPHIST(1,NPOS)
29083 IPH2 = IPHIST(2,NPOS)
29084
29085C back transformation and registration
29086 DO 300 I=1,3
29087 IF(ID(I).NE.0) THEN
29088 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29089 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29090 XX = PTOT*CX
29091 YY = PTOT*CY
29092 ZZ = PTOT*CZ
29093 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29094 & IPH1,IPH2,0,0,IPOS,1)
29095 ENDIF
29096 300 CONTINUE
29097
29098 400 CONTINUE
29099C debug output
29100 IF(IDEB(36).GE.20) THEN
29101 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29102 & '--------------------'
29103 CALL PHO_PREVNT(0)
29104 ENDIF
29105
29106 END
29107
29108*$ CREATE PHO_SDECY2.FOR
29109*COPY PHO_SDECY2
29110CDECK ID>, PHO_SDECY2
29111 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29112C**********************************************************************
29113C
29114C isotropic/anisotropic two particle decay in CM system,
29115C (transversely/longitudinally polarized boson into two
29116C pseudo-scalar mesons)
29117C
29118C**********************************************************************
29119 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29120 SAVE
29121
29122C input/output channels
29123 INTEGER LI,LO
29124 COMMON /POINOU/ LI,LO
29125C auxiliary data for three particle decay
29126 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29127 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29128
29129 UMO2=UMO*UMO
29130 AM11=AM1*AM1
29131 AM22=AM2*AM2
29132 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29133 ECM(2)=UMO-ECM(1)
29134 WAU=ECM(1)*ECM(1)-AM11
29135 IF(WAU.LT.0.D0) THEN
29136 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29137 CALL PHO_ABORT
29138 ENDIF
29139 PCM(1)=SQRT(WAU)
29140 PCM(2)=PCM(1)
29141
29142 CALL PHO_SFECFE(SIF(1),COF(1))
29143 IF(ISP.EQ.0) THEN
29144C no polarization
29145 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29146 ELSE IF(ISP.EQ.1) THEN
29147C transverse polarization
29148 400 CONTINUE
29149 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29150 SID12 = 1.D0-COD(1)*COD(1)
29151 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29152 ELSE IF(ISP.EQ.2) THEN
29153C longitudinal polarization
29154 500 CONTINUE
29155 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29156 COD12 = COD(1)*COD(1)
29157 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29158 ELSE
29159 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29160 & 'invalid polarization',ISP
29161 CALL PHO_ABORT
29162 ENDIF
29163
29164 COD(2) = -COD(1)
29165 COF(2) = -COF(1)
29166 SIF(2) = -SIF(1)
29167
29168 END
29169
29170*$ CREATE PHO_SDECY3.FOR
29171*COPY PHO_SDECY3
29172CDECK ID>, PHO_SDECY3
29173 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29174C**********************************************************************
29175C
29176C isotropic/anisotropic three particle decay in CM system,
29177C (transversely/longitudinally polarized boson into three
29178C pseudo-scalar mesons)
29179C
29180C**********************************************************************
29181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29182 SAVE
29183
29184 PARAMETER ( DEPS = 1.D-30,
29185 & EPS = 1.D-15 )
29186
29187C input/output channels
29188 INTEGER LI,LO
29189 COMMON /POINOU/ LI,LO
29190C auxiliary data for three particle decay
29191 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29192 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29193
29194 DIMENSION F(5),XX(5)
29195
29196C calculation of maximum of S2 phase space weight
29197 UMOO=UMO+UMO
29198 GU=(AM2+AM3)**2
29199 GO=(UMO-AM1)**2
29200 UFAK=1.0000000000001D0
29201 IF (GU.GT.GO) UFAK=0.99999999999999D0
29202 OFAK=2.D0-UFAK
29203 GU=GU*UFAK
29204 GO=GO*OFAK
29205 DS2=(GO-GU)/99.D0
29206 AM11=AM1*AM1
29207 AM22=AM2*AM2
29208 AM33=AM3*AM3
29209 UMO2=UMO*UMO
29210 RHO2=0.D0
29211 S22=GU
29212 DO 124 I=1,100
29213 S21=S22
29214 S22=GU+(I-1.D0)*DS2
29215 RHO1=RHO2
29216 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29217 IF(RHO2.LT.RHO1) GOTO 125
29218 124 CONTINUE
29219
29220 125 CONTINUE
29221 S2SUP=(S22-S21)/2.D0+S21
29222 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29223 & /(S2SUP+EPS)
29224 SUPRHO=SUPRHO*1.05D0
29225 XO=S21-DS2
29226 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29227 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29228 XX(1)=XO
29229 XX(3)=S22
29230 X1=(XO+S22)*0.5D0
29231 XX(2)=X1
29232 F(3)=RHO2
29233 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29234 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29235 DO 126 I=1,16
29236 X4=(XX(1)+XX(2))*0.5D0
29237 X5=(XX(2)+XX(3))*0.5D0
29238 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29239 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29240 XX(4)=X4
29241 XX(5)=X5
29242 DO 128 II=1,5
29243 IA=II
29244 DO 131 III=IA,5
29245 IF(F(II).LT.F(III)) THEN
29246 FH=F(II)
29247 F(II)=F(III)
29248 F(III)=FH
29249 FH=XX(II)
29250 XX(II)=XX(III)
29251 XX(III)=FH
29252 ENDIF
29253 131 CONTINUE
29254 128 CONTINUE
29255 SUPRHO=F(1)
29256 S2SUP=XX(1)
29257 DO 129 II=1,3
29258 IA=II
29259 DO 130 III=IA,3
29260 IF (XX(II).LT.XX(III)) THEN
29261 FH=F(II)
29262 F(II)=F(III)
29263 F(III)=FH
29264 FH=XX(II)
29265 XX(II)=XX(III)
29266 XX(III)=FH
29267 ENDIF
29268 130 CONTINUE
29269 129 CONTINUE
29270 126 CONTINUE
29271
29272 AM23=(AM2+AM3)**2
29273
29274C selection of S1
29275 ITH=0
29276 200 CONTINUE
29277 ITH=ITH+1
29278 IF(ITH.GT.200) THEN
29279 WRITE(LO,'(/1X,A,I10)')
29280 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29281 CALL PHO_ABORT
29282 ENDIF
29283 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29284 Y=DT_RNDM(AM23)*SUPRHO
29285 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29286 IF(Y.GT.RHO) GOTO 200
29287
29288C selection of S2
29289 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29290 & /(2.D0*S2)-RHO/2.D0
29291 S3=UMO2+AM11+AM22+AM33-S1-S2
29292 ECM(1)=(UMO2+AM11-S2)/UMOO
29293 ECM(2)=(UMO2+AM22-S3)/UMOO
29294 ECM(3)=(UMO2+AM33-S1)/UMOO
29295 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29296 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29297 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29298
29299C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29300 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29301 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29302 ELSE
29303 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29304 ENDIF
29305 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29306 & /(2.D0*PCM(2)*PCM(3))
29307 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29308 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29309 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29310
29311C selection of the sperical coordinates of particle 3
29312 CALL PHO_SFECFE(SIF(3),COF(3))
29313 IF(ISP.EQ.0) THEN
29314C no polarization
29315 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29316 ELSE IF(ISP.EQ.1) THEN
29317C transverse polarization
29318 400 CONTINUE
29319 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29320 SID32 = 1.D0-COD(3)*COD(3)
29321 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29322 ELSE IF(ISP.EQ.2) THEN
29323C longitudinal polarization
29324 500 CONTINUE
29325 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29326 COD32 = COD(3)*COD(3)
29327 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29328 ELSE
29329 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29330 & 'invalid polarization',ISP
29331 CALL PHO_ABORT
29332 ENDIF
29333
29334C selection of the rotation angle of p1-p2 plane along p3
29335 IF(ISP.EQ.0) THEN
29336 CALL PHO_SFECFE(SFE,CFE)
29337 ELSE
29338 SFE = 0.D0
29339 CFE = 1.D0
29340 ENDIF
29341 CX11=-COSTH1
29342 CY11=SINTH1*CFE
29343 CZ11=SINTH1*SFE
29344 CX22=-COSTH2
29345 CY22=-SINTH2*CFE
29346 CZ22=-SINTH2*SFE
29347
29348 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29349 COD(1)=CX11*COD(3)+CZ11*SID3
29350 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29351 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29352 & COD(1),COF(3),SID3,CX11,CZ11
29353 CALL PHO_PREVNT(-1)
29354 ENDIF
29355
29356 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29357 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29358 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29359 COD(2)=CX22*COD(3)+CZ22*SID3
29360 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29361 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29362 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29363
29364 END
29365
29366*$ CREATE PHO_DFMASS.FOR
29367*COPY PHO_DFMASS
29368CDECK ID>, PHO_DFMASS
29369 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29370C**********************************************************************
29371C
29372C sampling of Mx diffractive mass distribution within
29373C limits XMIN, XMAX
29374C
29375C input: XMIN,XMAX mass limitations (GeV)
29376C PREF2 original particle mass/ reference mass
29377C (squared, GeV**2)
29378C PVIRT2 particle virtuality
29379C IMODE M**2 mass distribution
29380C 1 1/(M**2+Q**2)
29381C 2 1/(M**2+Q**2)**alpha
29382C -1 1/(M**2-Mref**2+Q**2)
29383C -2 1/(M**2-Mref**2+Q**2)**alpha
29384C
29385C output: diffractive mass (GeV)
29386C
29387C**********************************************************************
29388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29389 SAVE
29390
29391 PARAMETER(EPS = 1.D-10)
29392
29393C input/output channels
29394 INTEGER LI,LO
29395 COMMON /POINOU/ LI,LO
29396C event debugging information
29397 INTEGER NMAXD
29398 PARAMETER (NMAXD=100)
29399 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29400 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29401 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29402 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29403C model switches and parameters
29404 CHARACTER*8 MDLNA
29405 INTEGER ISWMDL,IPAMDL
29406 DOUBLE PRECISION PARMDL
29407 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29408C some constants
29409 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29410 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29411 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29412
29413 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29414 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29415 & 'invalid mass limits',XMIN,XMAX,PREF2
29416 CALL PHO_PREVNT(-1)
29417 PHO_DFMASS = 0.135D0
29418 RETURN
29419 ENDIF
29420
29421 IF(IMODE.GT.0) THEN
29422 PM2 = -PVIRT2
29423 ELSE
29424 PM2 = PREF2 - PVIRT2
29425 ENDIF
29426
29427C critical pomeron
29428 IF(ABS(IMODE).EQ.1) THEN
29429 XMIN2 = LOG(XMIN**2-PM2)
29430 XMAX2 = LOG(XMAX**2-PM2)
29431 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29432 XMA2 = EXP(XI)+PM2
29433
29434C supercritical pomeron
29435 ELSE IF(ABS(IMODE).EQ.2) THEN
29436 DDELTA = 1.D0-PARMDL(48)
29437 XMIN2 = (XMIN**2-PM2)**DDELTA
29438 XMAX2 = (XMAX**2-PM2)**DDELTA
29439 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29440 XMA2 = XI**(1.D0/DDELTA)+PM2
29441 ELSE
29442 WRITE(LO,'(/,1X,A,I3)')
29443 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29444 CALL PHO_ABORT
29445 ENDIF
29446
29447 PHO_DFMASS = SQRT(XMA2)
29448C debug output
29449 IF(IDEB(43).GE.15) THEN
29450 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29451 & XMIN,XMAX,PREF2,SQRT(XMA2)
29452 ENDIF
29453
29454 END
29455
29456*$ CREATE PHO_DIFSLP.FOR
29457*COPY PHO_DIFSLP
29458CDECK ID>, PHO_DIFSLP
29459 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29460 & TT,SLWGHT,IREJ)
29461C**********************************************************************
29462C
29463C sampling of T (Mandelstam variable) distribution within
29464C certain limits TMIN, TMAX
29465C
29466C input: IDF1,2 type of diffractive vertex
29467C 0 elastic/quasi-elastic scattering
29468C 1 diffraction dissociation
29469C IVEC1,2 vector meson IDs in case of quasi-elastic
29470C scattering, otherwise 0
29471C XM1 mass of diffractive system 1 (GeV)
29472C XM2 mass of diffractive system 2 (GeV)
29473C XMX max. mass of diffractive system (GeV)
29474C
29475C output: TT squared momentum transfer ( < 0, GeV**2)
29476C SLWGHT weight to allow for mass-dependent slope
29477C IREJ 0 successful sampling
29478C 1 masses too big for given T range
29479C
29480C**********************************************************************
29481 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29482 SAVE
29483
29484 PARAMETER(EPS = 1.D-10)
29485
29486C input/output channels
29487 INTEGER LI,LO
29488 COMMON /POINOU/ LI,LO
29489C event debugging information
29490 INTEGER NMAXD
29491 PARAMETER (NMAXD=100)
29492 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29493 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29494 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29495 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29496C model switches and parameters
29497 CHARACTER*8 MDLNA
29498 INTEGER ISWMDL,IPAMDL
29499 DOUBLE PRECISION PARMDL
29500 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29501C internal rejection counters
29502 INTEGER NMXJ
29503 PARAMETER (NMXJ=60)
29504 CHARACTER*10 REJTIT
29505 INTEGER IFAIL
29506 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29507C c.m. kinematics of diffraction
29508 INTEGER NPOSD
29509 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29510 & SIDD,CODD,SIFD,COFD,PDCMS
29511 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29512 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29513C cross sections
29514 INTEGER IPFIL,IFAFIL,IFBFIL
29515 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29516 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29517 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29518 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29519 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29520 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29521 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29522 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29523 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29524 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29525 & IPFIL,IFAFIL,IFBFIL
29526C Reggeon phenomenology parameters
29527 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29528 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29529 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29530 & ALREG,ALREGP,GR(2),B0REG(2),
29531 & GPPP,GPPR,B0PPP,B0PPR,
29532 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29533C parameters of 2x2 channel model
29534 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29535 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29536C parameters of the "simple" Vector Dominance Model
29537 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29538 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29539C some constants
29540 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29541 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29542 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29543
29544 IREJ = 0
29545 XM12 = XM1**2
29546 XM22 = XM2**2
29547 SS = ECMD**2
29548C
29549C range of momentum transfer t
29550 TMIN = -PARMDL(68)
29551 TMAX = -PARMDL(69)
29552C determine min. abs(t) necessary to produce masses
29553 PCM2 = PCMD**2
29554 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29555 IF(PCMP2.LE.0.D0) THEN
29556 IREJ = 1
29557 TT = 0.D0
29558 RETURN
29559 ENDIF
29560 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29561 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29562C
29563 IF(TMINP.LT.TMAX) THEN
29564 IF(IDEB(44).GE.3) THEN
29565 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29566 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29567 & XM1,XM2,TMIN,TMAX,TMINP
29568 ENDIF
29569 IFAIL(32) = IFAIL(32)+1
29570 IREJ = 1
29571 TT = 0.D0
29572 RETURN
29573 ENDIF
29574 TMINA = MIN(TMIN,TMINP)
29575C
29576C calculation of slope (mass-dependent parametrization)
29577 IF(IDF1+IDF2.GT.0) THEN
29578C diffraction dissociation
29579 XMP12 = XM1**2+PVIRTD(1)
29580 XMP22 = XM2**2+PVIRTD(2)
29581 XMX1 = SQRT(XMP12)
29582 XMX2 = SQRT(XMP22)
29583 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29584 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29585 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29586 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29587 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29588 SLOPE = MAX(SLOPE,1.D0)
29589C
29590 XMA1 = XMX
29591 XMA2 = XMX
29592 IF(IDF1.EQ.0) THEN
29593 XMA1 = XM1
29594 ELSE IF(IDF1.EQ.0) THEN
29595 XMA2 = XM2
29596 ENDIF
29597 XMP12 = XMA1**2+PVIRTD(1)
29598 XMP22 = XMA2**2+PVIRTD(2)
29599 XMX1 = SQRT(XMP12)
29600 XMX2 = SQRT(XMP22)
29601 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29602 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29603 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29604 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29605 SLMIN = MAX(SLMIN,1.D0)
29606 ELSE
29607C elastic/quasi-elastic scattering
29608 IF(ISWMDL(13).EQ.0) THEN
29609C external slope values
ecf67adb 29610 WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
9aaba0d6 29611 CALL PHO_ABORT
29612 ELSE IF(ISWMDL(13).EQ.1) THEN
29613C model slopes
29614 IF(IVEC1*IVEC2.EQ.0) THEN
29615 SLOPE = SLOEL
29616 ELSE
29617 SLOPE = SLOVM(IVEC1,IVEC2)
29618 ENDIF
29619 SLMIN = SLOPE
29620 ELSE
29621 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29622 & ISWMDL(13)
29623 CALL PHO_ABORT
29624 ENDIF
29625 ENDIF
29626C
29627C determine max. abs(t) to avoid underflows
29628 TMAXP = -25.D0/SLOPE
29629 TMAXA = MAX(TMAX,TMAXP)
29630C
29631 IF(TMINA.LT.TMAXA) THEN
29632 IF(IDEB(44).GE.3) THEN
29633 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29634 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29635 & XM1,XM2,TMINA,TMAXA,SLOPE
29636 ENDIF
29637 IFAIL(32) = IFAIL(32)+1
29638 IREJ = 1
29639 TT = 0.D0
29640 RETURN
29641 ENDIF
29642C
29643C sampling from corrected range of T
29644 TMINE = EXP(SLMIN*TMINA)
29645 TMAXE = EXP(SLMIN*TMAXA)
29646 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29647 TT = LOG(XI)/SLMIN
29648 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29649C
29650C debug output
29651 IF(IDEB(44).GE.15) THEN
29652 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29653 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29654 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29655 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29656 ENDIF
29657 END
29658
29659*$ CREATE PHO_DIFKIN.FOR
29660*COPY PHO_DIFKIN
29661CDECK ID>, PHO_DIFKIN
29662 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29663C**********************************************************************
29664C
29665C calculation of diffractive kinematics
29666C
29667C input: XMP1 mass of outgoing particle system 1 (GeV)
29668C XMP2 mass of outgoing particle system 2 (GeV)
29669C TT momentum transfer (GeV**2, negative)
29670C
29671C output: PMOM1(5) four momentum of outgoing system 1
29672C PMOM2(5) four momentum of outgoing system 2
29673C IREJ 0 kinematics consistent
29674C 1 kinematics inconsistent
29675C
29676C**********************************************************************
29677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29678 SAVE
29679
29680 PARAMETER(EPS = 1.D-10,
29681 & DEPS = 0.001)
29682
29683C input/output channels
29684 INTEGER LI,LO
29685 COMMON /POINOU/ LI,LO
29686C event debugging information
29687 INTEGER NMAXD
29688 PARAMETER (NMAXD=100)
29689 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29690 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29691 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29692 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29693C c.m. kinematics of diffraction
29694 INTEGER NPOSD
29695 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29696 & SIDD,CODD,SIFD,COFD,PDCMS
29697 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29698 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29699C some constants
29700 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29701 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29702 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29703
29704 DOUBLE PRECISION PMOM1,PMOM2
29705 DIMENSION PMOM1(5),PMOM2(5)
29706
29707C debug output
29708 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29709 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29710 & ECMD,PCMD,XMP1,XMP2,TT
29711
29712C general kinematic constraints
29713 IREJ = 1
29714 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29715
29716C new squared cms momentum
29717 XMP12 = XMP1**2
29718 XMP22 = XMP2**2
29719 SS = ECMD**2
29720 PCM2 = PCMD**2
29721 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29722
29723C new longitudinal/transverse momentum
29724 E1I = SQRT(PCM2+PMASSD(1)**2)
29725 E1F = SQRT(PCMP2+XMP12)
29726 E2F = SQRT(PCMP2+XMP22)
29727 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29728 PTRAN = PCMP2-PLONG**2
29729
29730C check consistency of kinematics
29731 IF(PTRAN.LT.0.D0) THEN
29732 IF(IDEB(49).GE.1) THEN
29733 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29734 & 'inconsistent kinematics in event call: ',KEVENT
29735 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29736 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29737 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29738 ENDIF
29739 IREJ = 1
29740 RETURN
29741 ELSE
29742 PTRAN = SQRT(PTRAN)
29743 ENDIF
29744 XI = PI2*DT_RNDM(PTRAN)
29745
29746C outgoing momenta in cm. system
29747 PMOM1(4) = E1F
29748 PMOM1(1) = PTRAN*COS(XI)
29749 PMOM1(2) = PTRAN*SIN(XI)
29750 PMOM1(3) = PLONG
29751 PMOM1(5) = XMP1
29752
29753 PMOM2(4) = E2F
29754 PMOM2(1) = -PMOM1(1)
29755 PMOM2(2) = -PMOM1(2)
29756 PMOM2(3) = -PLONG
29757 PMOM2(5) = XMP2
29758 IREJ = 0
29759
29760C debug output / precision check
29761 IF(IDEB(49).GE.0) THEN
29762C check kinematics
29763 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29764 & -PMOM1(1)**2-PMOM1(2)**2
29765 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29766 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29767 & -PMOM2(1)**2-PMOM2(2)**2
29768 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29769 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29770 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29771 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29772 & XMP1,XM1,XMP2,XM2
29773 CALL PHO_PREVNT(-1)
29774 ENDIF
29775C output
29776 IF(IDEB(49).GT.10) THEN
29777 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29778 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
29779 ENDIF
29780 ENDIF
29781
29782 END
29783
29784*$ CREATE PHO_VECRES.FOR
29785*COPY PHO_VECRES
29786CDECK ID>, PHO_VECRES
29787 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29788C**********************************************************************
29789C
29790C sampling of vector meson resonance in diffractive processes
29791C (nothing done for hadrons)
29792C
29793C input: /POSVDM/ VDMFAC factors
29794C
29795C output: IVEC 0 incoming hadron
29796C 1 rho 0
29797C 2 omega
29798C 3 phi
29799C 4 pi+/pi- background
29800C RMASS mass of vector meson (GeV)
29801C IDPDG particle ID according to PDG
29802C IDBAM particle ID according to CPC
29803C
29804C**********************************************************************
29805 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29806 SAVE
29807
29808 PARAMETER(EPS = 1.D-10)
29809
29810C input/output channels
29811 INTEGER LI,LO
29812 COMMON /POINOU/ LI,LO
29813C event debugging information
29814 INTEGER NMAXD
29815 PARAMETER (NMAXD=100)
29816 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29817 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29818 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29819 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29820C nucleon-nucleus / nucleus-nucleus interface to DPMJET
29821 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29822 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29823 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29824 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29825C parameters of the "simple" Vector Dominance Model
29826 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29827 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29828C some constants
29829 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29830 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29831 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29832
29833C particle code translation
29834 DIMENSION ITRANS(4)
29835C rho0,omega,phi,pi+/pi-
29836 DATA ITRANS /113, 223, 333, 92 /
29837
29838 IDPDO = IDPDG
29839C
29840C vector meson production
29841 IF(IDPDG.EQ.22) THEN
29842 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29843 SUM = 0.D0
29844 DO 55 K=1,4
29845 SUM = SUM + VMFA(K)
29846 IF(XI.LE.SUM) GOTO 65
29847 55 CONTINUE
29848 65 CONTINUE
29849C
29850 IDPDG = ITRANS(K)
29851 IDBAM = ipho_pdg2id(IDPDG)
29852 IVEC = K
29853C sample mass of vector meson
29854 CALL PHO_SAMASS(IDPDG,RMASS)
29855
29856C hadronic resonance of multi-pomeron coupling
29857 ELSE IF(IDPDG.EQ.990) THEN
29858 K = 4
29859 IDPDG = 91
29860 IDBAM = ipho_pdg2id(IDPDG)
29861 IVEC = 4
29862C sample mass of two-pion system
29863 CALL PHO_SAMASS(IDPDG,RMASS)
29864
29865C hadron remnants in inucleus interactions
29866 ELSE IF(IDPDG.EQ.81) THEN
29867 IF(IHFLD(1,1).EQ.0) THEN
29868 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29869 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29870 ELSE
29871 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29872 ENDIF
29873 RMAS1 = PHO_PMASS(IDBA1,0)
29874 RMAS2 = PHO_PMASS(IDBA2,0)
29875 IF((IDBA2.NE.0).AND.
29876 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29877 IDBAM = IDBA2
29878 RMASS = RMAS2
29879 ELSE
29880 IDBAM = IDBA1
29881 RMASS = RMAS1
29882 ENDIF
29883 IDPDG = IPHO_ID2PDG(IDBAM)
29884 IVEC = 0
29885 ELSE IF(IDPDG.EQ.82) THEN
29886 IF(IHFLD(2,1).EQ.0) THEN
29887 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29888 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29889 ELSE
29890 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29891 ENDIF
29892 RMAS1 = PHO_PMASS(IDBA1,0)
29893 RMAS2 = PHO_PMASS(IDBA2,0)
29894 IF((IDBA2.NE.0).AND.
29895 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29896 IDBAM = IDBA2
29897 RMASS = RMAS2
29898 ELSE
29899 IDBAM = IDBA1
29900 RMASS = RMAS1
29901 ENDIF
29902 IDPDG = IPHO_ID2PDG(IDBAM)
29903 IVEC = 0
29904 ENDIF
29905C debug output
29906 IF(IDEB(47).GE.5) THEN
29907 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29908 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29909 & IDPDO,IDPDG,IDBAM,RMASS
29910 ENDIF
29911
29912 END
29913
29914*$ CREATE PHO_DIFRES.FOR
29915*COPY PHO_DIFRES
29916CDECK ID>, PHO_DIFRES
29917 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29918 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29919C**********************************************************************
29920C
29921C list of resonance states for low mass resonances
29922C
29923C input: IDMOTH PDG ID of mother particle
29924C IVAL1,2 quarks (photon only)
29925C
29926C output: IDPDG list of PDG IDs for possible resonances
29927C IDBAM list of corresponding CPC IDs
29928C RMASS mass
29929C RGAMS decay width
29930C RMASS additional weight factor
29931C LISTL entries in current list
29932C
29933C**********************************************************************
29934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29935 SAVE
29936
29937 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29938
29939 PARAMETER (EPS = 1.D-10,
29940 & DEPS = 1.D-15)
29941
29942C input/output channels
29943 INTEGER LI,LO
29944 COMMON /POINOU/ LI,LO
29945C event debugging information
29946 INTEGER NMAXD
29947 PARAMETER (NMAXD=100)
29948 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29949 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29950 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29951 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29952C particle ID translation table
29953 integer ID_pdg_list,ID_list,ID_pdg_max
29954 character*12 name_list
29955 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29956 & ID_pdg_max
29957C general particle data
29958 double precision xm_list,tau_list,gam_list,
29959 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29960 & xm_bb82_list,xm_bb102_list
29961 integer ich3_list,iba3_list,iq_list,
29962 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29963 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29964 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29965 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29966 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29967 & ich3_list(300),iba3_list(300),iq_list(3,300),
29968 & id_psm_list(6,6),id_vem_list(6,6),
29969 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29970
29971 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29972 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29973 & 12212, 42212, -12212, -42212,
29974 & 8*0 /
29975 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29976 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29977 & 8*1.D0 /
29978
29979 DATA init /0/
29980
29981C initialize table
29982 if(init.eq.0) then
29983 do i=1,20
29984 if(IRPDG(i).ne.0) then
29985 IRBAM(i) = ipho_pdg2id(IRPDG(i))
29986 endif
29987 enddo
29988 init = 1
29989 endif
29990
29991C copy table with particles and isospin weights
29992 LISTL = 0
29993 IF(IDMOTH.EQ.22) THEN
29994 I1 = 4
29995 I2 = 8
29996 ELSE IF(IDMOTH.EQ.2212) THEN
29997 I1 = 9
29998 I2 = 10
29999 ELSE IF(IDMOTH.EQ.-2212) THEN
30000 I1 = 11
30001 I2 = 12
30002 ELSE
30003 RETURN
30004 ENDIF
30005
30006 DO 100 I=I1,I2
30007 LISTL = LISTL+1
30008 IDBAM(LISTL) = IRBAM(I)
30009 IDPDG(LISTL) = IRPDG(I)
30010 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30011 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
30012 RWG(LISTL) = RWGHT(I)
30013 100 CONTINUE
30014
30015C debug output
30016 IF(IDEB(85).GE.20) THEN
30017 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30018 & IVAL1,IVAL2
30019 DO 200 I=1,LISTL
30020 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30021 200 CONTINUE
30022 ENDIF
30023
30024 END
30025
30026*$ CREATE PHO_MASSAD.FOR
30027*COPY PHO_MASSAD
30028CDECK ID>, PHO_MASSAD
30029 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30030 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30031C***********************************************************************
30032C
30033C fine-correction of low mass strings to mass of corresponding
30034C resonance or two particle threshold
30035C
30036C input: IFLMO PDG ID of mother particle
30037C IFL1,2 requested parton flavours
30038C (not used at the moment)
30039C PMASS reference mass (mass of mother particle)
30040C XMCON conjecture of mass
30041C
30042C output: XMOUT output mass (adjusted input mass)
30043C moved ot nearest mass possible
30044C IDPDG PDG resonance ID
30045C IDcpc CPC resonance ID
30046C
30047C**********************************************************************
30048 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30049 SAVE
30050
30051 PARAMETER ( DEPS = 1.D-8 )
30052
30053C input/output channels
30054 INTEGER LI,LO
30055 COMMON /POINOU/ LI,LO
30056C event debugging information
30057 INTEGER NMAXD
30058 PARAMETER (NMAXD=100)
30059 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30060 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30061 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30062 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30063C model switches and parameters
30064 CHARACTER*8 MDLNA
30065 INTEGER ISWMDL,IPAMDL
30066 DOUBLE PRECISION PARMDL
30067 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30068C general particle data
30069 double precision xm_list,tau_list,gam_list,
30070 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30071 & xm_bb82_list,xm_bb102_list
30072 integer ich3_list,iba3_list,iq_list,
30073 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30074 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30075 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30076 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30077 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30078 & ich3_list(300),iba3_list(300),iq_list(3,300),
30079 & id_psm_list(6,6),id_vem_list(6,6),
30080 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30081C particle decay data
30082 double precision wg_sec_list
30083 integer idec_list,isec_list
30084 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30085 & isec_list(3,500)
30086
30087 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30088
30089 XMINP = XMCON
30090 IDPDG = 0
30091 IDcpc = 0
30092 XMOUT = XMINP
30093
30094C resonance treatment activated?
30095 IF(ISWMDL(23).EQ.0) RETURN
30096
30097 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30098 IF(LISTL.LT.1) THEN
30099 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30100 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30101 & IFLMO,IFL1,IFL2
30102 GOTO 50
30103 ENDIF
30104C mass small?
30105 PMASSL = (PMASS+0.15D0)**2
30106 XMINP2 = XMINP**2
30107C determine resonance probability
30108 DM2 = 1.1D0
30109 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30110 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30111C sample new resonance
30112 XWGSUM = 0.D0
30113 DO 100 I=1,LISTL
30114 XWG(I) = RWG(I)/RMA(I)**2
30115 XWGSUM = XWGSUM+XWG(I)
30116 100 CONTINUE
30117
30118 ITER = 0
30119 150 CONTINUE
30120 ITER = ITER+1
30121 IF(ITER.GE.5) THEN
30122 IDcpc = 0
30123 IDPDG = 0
30124 XMOUT = XMINP
30125 GOTO 50
30126 ENDIF
30127
30128 I = 0
30129 XI = XWGSUM*DT_RNDM(XMOUT)
30130 200 CONTINUE
30131 I = I+1
30132 XWGSUM = XWGSUM-XWG(I)
30133 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30134 IDPDG = IRPDG(I)
30135 IDcpc = IRBAM(I)
30136 GARES = RGA(I)
30137 XMRES = RMA(I)
30138 XMRES2 = XMRES**2
30139C sample new mass (from Breit-Wigner cross section)
30140 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30141 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30142 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30143 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30144 XMOUT = SQRT(XMOUT)
30145
30146C check mass for decay
30147 AMDCY = 2.D0*XMRES
30148 ID = abs(IDcpc)
30149 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30150 AMSUM = 0.D0
30151 DO 275 I=1,3
30152 IF(isec_list(I,IK).NE.0)
30153 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30154 275 CONTINUE
30155 AMDCY = MIN(AMDCY,AMSUM)
30156 250 CONTINUE
30157 IF(AMDCY.GE.XMOUT) GOTO 150
30158
30159C debug output
30160 IF(IDEB(7).GE.10)
30161 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30162 & 'PHO_MASSAD: ',
30163 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30164 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30165 RETURN
30166 ENDIF
30167
30168 50 CONTINUE
30169C debug output
30170 IF(IDEB(7).GE.15)
30171 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30172 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30173 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30174
30175 END
30176
30177*$ CREATE PHO_PDF.FOR
30178*COPY PHO_PDF
30179CDECK ID>, PHO_PDF
30180 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30181C***************************************************************
30182C
30183C call different PDF sets for different particle types
30184C
30185C input: NPAR 1 IGRP(1),ISET(1)
30186C 2 IGRP(2),ISET(2)
30187C X momentum fraction
30188C SCALE2 squared scale (GeV**2)
30189C P2VIR particle virtuality (positive, GeV**2)
30190C
30191C output PD(-6:6) field containing the x*PDF fractions
30192C
30193C***************************************************************
30194 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30195 SAVE
30196
30197 DIMENSION PD(-6:6)
30198
30199C input/output channels
30200 INTEGER LI,LO
30201 COMMON /POINOU/ LI,LO
30202C currently activated parton density parametrizations
30203 CHARACTER*8 PDFNAM
30204 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30205 DOUBLE PRECISION PDFLAM,PDFQ2M
30206 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30207 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30208C event debugging information
30209 INTEGER NMAXD
30210 PARAMETER (NMAXD=100)
30211 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30212 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30213 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30214 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215C model switches and parameters
30216 CHARACTER*8 MDLNA
30217 INTEGER ISWMDL,IPAMDL
30218 DOUBLE PRECISION PARMDL
30219 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30220
30221 DIMENSION PARAM(20),VALUE(20)
30222 CHARACTER*20 PARAM
30223
30224 REAL XR,P2R,Q2R,F2GM,XPDFGM
30225 DIMENSION XPDFGM(-6:6)
30226
30227C check of kinematic boundaries
30228 XI = X
30229 IF(X.GT.1.D0) THEN
30230 IF(IDEB(37).GE.0) THEN
30231 WRITE(LO,'(/,1X,A,E15.8/)')
30232 & 'PHO_PDF: x>1 (corrected to x=1)',X
30233 CALL PHO_PREVNT(-1)
30234 ENDIF
30235 XI = 0.99999999999D0
30236 ELSE IF(X.LE.0.D0) THEN
30237 IF(IDEB(37).GE.0) THEN
30238 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30239 CALL PHO_PREVNT(-1)
30240 ENDIF
30241 XI = 0.0001D0
30242 ENDIF
30243
30244 DO 100 I=-6,6
30245 PD(I) = 0.D0
30246 100 CONTINUE
30247 IRET = 1
30248
30249 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30250
30251C internal PDFs
30252
30253 IF(IEXT(NPAR).EQ.0) THEN
30254 IF(ITYPE(NPAR).EQ.1) THEN
30255C proton PDFs
30256 IF(IGRP(NPAR).EQ.5) THEN
30257 IF(ISET(NPAR).EQ.3) THEN
30258 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30259 UV = UDV-DV
30260 UDB = 2.D0*UDB
30261 DEL = 0.D0
30262 IRET = 0
30263 ELSE IF(ISET(NPAR).EQ.4) THEN
30264 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30265 UV = UDV-DV
30266 UDB = 2.D0*UDB
30267 DEL = 0.D0
30268 IRET = 0
30269 ELSE IF(ISET(NPAR).EQ.5) THEN
30270 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30271C heavy quarks from GRV92-HO
30272 AMU2 = 0.3
30273 ALAM2 = 0.248 * 0.248
30274 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30275 SC = 0.820
30276 ALC = 0.98
30277 BEC = 0.0
30278 AKC = -0.625 - 0.523 * S
30279 AGC = 0.0
30280 BC = 1.896 + 1.616 * S
30281 DC = 4.12 + 0.683 * S
30282 EC = 4.36 + 1.328 * S
30283 ESC = 0.677 + 0.679 * S
30284 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30285 SBO = 1.297
30286 ALB = 0.99
30287 BEB = 0.0
30288 AKB = 0.0 - 0.193 * S
30289 AGB = 0.0
30290 BBO = 0.0
30291 DB = 3.447 + 0.927 * S
30292 EB = 4.68 + 1.259 * S
30293 ESB = 1.892 + 2.199 * S
30294 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30295 IRET = 0
30296 ELSE IF(ISET(NPAR).EQ.6) THEN
30297 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30298C heavy quarks from GRV92-LO
30299 AMU2 = 0.25
30300 ALAM2 = 0.232D0**2
30301 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30302 SC = 0.888
30303 ALC = 1.01
30304 BEC = 0.37
30305 AKC = 0.0
30306 AGC = 0.0
30307 BC = 4.24 - 0.804 * S
30308 DC = 3.46 + 1.076 * S
30309 EC = 4.61 + 1.490 * S
30310 ESC = 2.555 + 1.961 * S
30311 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30312 SBO = 1.351
30313 ALB = 1.00
30314 BEB = 0.51
30315 AKB = 0.0
30316 AGB = 0.0
30317 BBO = 1.848
30318 DB = 2.929 + 1.396 * S
30319 EB = 4.71 + 1.514 * S
30320 ESB = 4.02 + 1.239 * S
30321 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30322 IRET = 0
30323 ELSE IF(ISET(NPAR).EQ.7) THEN
30324 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30325C heavy quarks from GRV92-HO
30326 AMU2 = 0.3
30327 ALAM2 = 0.248 * 0.248
30328 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30329 SC = 0.820
30330 ALC = 0.98
30331 BEC = 0.0
30332 AKC = -0.625 - 0.523 * S
30333 AGC = 0.0
30334 BC = 1.896 + 1.616 * S
30335 DC = 4.12 + 0.683 * S
30336 EC = 4.36 + 1.328 * S
30337 ESC = 0.677 + 0.679 * S
30338 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30339 SBO = 1.297
30340 ALB = 0.99
30341 BEB = 0.0
30342 AKB = 0.0 - 0.193 * S
30343 AGB = 0.0
30344 BBO = 0.0
30345 DB = 3.447 + 0.927 * S
30346 EB = 4.68 + 1.259 * S
30347 ESB = 1.892 + 2.199 * S
30348 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30349 IRET = 0
30350 ELSE IF(ISET(NPAR).EQ.8) THEN
30351 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30352 DEL = DS-US
30353 UDB = DS+US
30354C heavy quarks from GRV92-LO
30355 AMU2 = 0.25
30356 ALAM2 = 0.232D0**2
30357 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30358 SC = 0.888
30359 ALC = 1.01
30360 BEC = 0.37
30361 AKC = 0.0
30362 AGC = 0.0
30363 BC = 4.24 - 0.804 * S
30364 DC = 3.46 + 1.076 * S
30365 EC = 4.61 + 1.490 * S
30366 ESC = 2.555 + 1.961 * S
30367 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30368 SBO = 1.351
30369 ALB = 1.00
30370 BEB = 0.51
30371 AKB = 0.0
30372 AGB = 0.0
30373 BBO = 1.848
30374 DB = 2.929 + 1.396 * S
30375 EB = 4.71 + 1.514 * S
30376 ESB = 4.02 + 1.239 * S
30377 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30378 IRET = 0
30379 ELSE IF(ISET(NPAR).EQ.9) THEN
30380* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30381 DEL = DS-US
30382 UDB = DS+US
30383C heavy quarks from GRV92-LO
30384 AMU2 = 0.25
30385 ALAM2 = 0.232D0**2
30386 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30387 SC = 0.888
30388 ALC = 1.01
30389 BEC = 0.37
30390 AKC = 0.0
30391 AGC = 0.0
30392 BC = 4.24 - 0.804 * S
30393 DC = 3.46 + 1.076 * S
30394 EC = 4.61 + 1.490 * S
30395 ESC = 2.555 + 1.961 * S
30396 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30397 SBO = 1.351
30398 ALB = 1.00
30399 BEB = 0.51
30400 AKB = 0.0
30401 AGB = 0.0
30402 BBO = 1.848
30403 DB = 2.929 + 1.396 * S
30404 EB = 4.71 + 1.514 * S
30405 ESB = 4.02 + 1.239 * S
30406 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30407 IRET = 0
30408 ENDIF
30409 PD(-5) = BB
30410 PD(-4) = CB
30411 PD(-3) = SB
30412 PD(-2) = 0.5D0*(UDB-DEL)
30413 PD(-1) = 0.5D0*(UDB+DEL)
30414 PD(0) = GL
30415 PD(1) = DV+PD(-1)
30416 PD(2) = UV+PD(-2)
30417 PD(3) = PD(-3)
30418 PD(4) = PD(-4)
30419 PD(5) = PD(-5)
30420 ENDIF
30421 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30422C pion PDFs (default for pi+)
30423 IF(IGRP(NPAR).EQ.5) THEN
30424 IF(ISET(NPAR).EQ.1) THEN
30425 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30426 IRET = 0
30427 ELSE IF(ISET(NPAR).EQ.2) THEN
30428 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30429 IRET = 0
30430 ENDIF
30431 PD(-5) = BB
30432 PD(-4) = CB
30433 PD(-3) = QB
30434 PD(-2) = QB
30435 PD(-1) = QB+VA
30436 PD(0) = GL
30437 PD(1) = QB
30438 PD(2) = VA+QB
30439 PD(3) = QB
30440 PD(4) = CB
30441 PD(5) = BB
30442 ENDIF
30443 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30444C photon PDFs
30445 IF(IGRP(NPAR).EQ.5) THEN
30446 IF(ISET(NPAR).EQ.1) THEN
30447 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30448 IRET = 0
30449 ELSE IF(ISET(NPAR).EQ.2) THEN
30450 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30451 IRET = 0
30452 ELSE IF(ISET(NPAR).EQ.3) THEN
30453 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30454 IRET = 0
30455 ENDIF
30456C reweight with Drees-Godbole factor
30457 WGX = 1.D0
30458 IF(P2VIR.GT.0.001D0) THEN
30459 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30460 & /LOG(SCALE2/PARMDL(144))
30461 WGX = MAX(WGX,0.D0)
30462 ENDIF
30463 PD(-5) = BB*WGX/137.D0
30464 PD(-4) = CB*WGX/137.D0
30465 PD(-3) = SB*WGX/137.D0
30466 PD(-2) = UB*WGX/137.D0
30467 PD(-1) = DB*WGX/137.D0
30468 PD(0) = GL*WGX*WGX/137.D0
30469 PD(1) = PD(-1)
30470 PD(2) = PD(-2)
30471 PD(3) = PD(-3)
30472 PD(4) = PD(-4)
30473 PD(5) = PD(-5)
30474 ELSE IF(IGRP(NPAR).EQ.8) THEN
30475 IF(ISET(NPAR).EQ.1) THEN
30476 CALL PHO_PHGAL (XI,SCALE2,PD)
30477 IRET = 0
30478 ENDIF
30479 ENDIF
30480 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30481C Pomeron PDFs
30482 MODE = IGRP(NPAR)
30483 IF(MODE.EQ.1) THEN
30484 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30485 IRET = 0
30486 ELSE IF(MODE.EQ.2) THEN
30487 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30488 IRET = 0
30489 ELSE IF(MODE.EQ.3) THEN
30490 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30491 IRET = 0
30492 ELSE IF(MODE.EQ.4) THEN
30493 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30494 DO 105 I=-4,4
30495 PD(I) = PD(I)*PARMDL(78)
30496 105 CONTINUE
30497 IRET = 0
30498 ENDIF
30499 ENDIF
30500
30501C external PDFs
30502
30503 ELSE IF(IEXT(NPAR).EQ.2) THEN
30504C PDFLIB call: new PDF numbering
30505 IF(NPAR.NE.NPAOLD) THEN
30506 PARAM(1) = 'NPTYPE'
30507 PARAM(2) = 'NGROUP'
30508 PARAM(3) = 'NSET'
30509 PARAM(4) = ' '
30510 VALUE(1) = ITYPE(NPAR)
30511 VALUE(2) = ABS(IGRP(NPAR))
30512 VALUE(3) = ISET(NPAR)
30513 CALL PDFSET(PARAM,VALUE)
30514 ENDIF
30515 IF(ITYPE(NPAR).EQ.3) THEN
30516 IP2 = 0
30517 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30518 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30519 ELSE
30520 SCALE = SQRT(SCALE2)
30521 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30522 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30523 ENDIF
30524 DO 115 I=3,6
30525 PD(I) = PD(-I)
30526 115 CONTINUE
30527 IF(ITYPE(NPAR).EQ.1) THEN
30528C proton valence quarks
30529 PD(1) = PD(1)+PD(-1)
30530 PD(2) = PD(2)+PD(-2)
30531 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30532C pi+ valences
30533 DVAL = PD(1)
30534 PD(1) = PD(-1)
30535 PD(-1) = DVAL+PD(1)
30536 PD(2) = PD(2)+PD(-2)
30537 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30538C photon conventions
30539 PD(1) = PD(-1)
30540 PD(2) = PD(-2)
30541 ENDIF
30542 IRET = 0
30543
30544 ELSE IF(IEXT(NPAR).EQ.3) THEN
30545C PHOLIB call: version 2.0
30546 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30547 IF(IRET.LT.0) THEN
30548 WRITE(LO,'(/1X,A,I2)')
30549 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30550 CALL PHO_ABORT
30551 ENDIF
30552 IRET = 0
30553
30554C photon PDFs depending on photon virtuality
30555
30556 ELSE IF(IEXT(NPAR).EQ.4) THEN
30557 IF(IGRP(NPAR).EQ.1) THEN
30558C Schuler/Sjostrand PDF (interface to single precision)
30559 XR = XI
30560 Q2R = SCALE2
30561 P2R = P2VIR
30562 IP2 = 0
30563 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30564 DO 120 I=-6,6
30565 PD(I) = DBLE(XPDFGM(I))
30566 120 CONTINUE
30567 IRET = 0
30568 ELSE IF(IGRP(NPAR).EQ.5) THEN
30569C Gluck/Reya/Stratmann
30570 IF(ISET(NPAR).EQ.4) THEN
30571 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30572 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30573 IRET = 0
30574 PD(-5) = 0.D0
30575 PD(-4) = CB
30576 PD(-3) = SB/137.D0
30577 PD(-2) = UB/137.D0
30578 PD(-1) = DB/137.D0
30579 PD(0) = GL/137.D0
30580 PD(1) = PD(-1)
30581 PD(1) = PD(-1)
30582 PD(2) = PD(-2)
30583 PD(3) = PD(-3)
30584 PD(4) = PD(-4)
30585 PD(5) = PD(-5)
30586 ENDIF
30587 ENDIF
30588 ENDIF
30589
30590C check for errors
30591
30592 IF(IRET.NE.0) THEN
30593 WRITE(LO,'(/1X,A,/10X,5I6)')
30594 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30595 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30596 CALL PHO_ABORT
30597 ENDIF
30598C error in NPAR
30599 ELSE
30600 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30601 CALL PHO_ABORT
30602 ENDIF
30603 NPAOLD = NPAR
30604
30605C valence quark treatment
30606
30607 IF(ITYPE(NPAR).EQ.2) THEN
30608C meson conventions
30609 IF(IPARID(NPAR).EQ.111) THEN
30610C pi0 valence quarks
30611 PD(-1) = (PD(1)+PD(-1))/2.D0
30612 PD(1) = PD(-1)
30613 PD(-2) = (PD(2)+PD(-2))/2.D0
30614 PD(2) = PD(-2)
30615 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30616C K+/-
30617 VALS = PD(-1)-PD(1)
30618 PD(-1) = PD(1)
30619 PD(-3) = PD(-3)+VALS
30620 ELSE IF( (IPARID(NPAR).EQ.311)
30621 & .OR.(IPARID(NPAR).EQ.310)
30622 & .OR.(IPARID(NPAR).EQ.130)) THEN
30623C neutral kaons
30624 VALS = PD(-1)-PD(1)
30625 VALU = PD(2)-PD(-2)
30626 PD(-1) = PD(1)
30627 PD(2) = PD(-2)
30628 PD(2) = PD(2)+VALU/2.D0
30629 PD(-2) = PD(-2)+VALU/2.D0
30630 PD(3) = PD(3)+VALS/2.D0
30631 PD(-3) = PD(-3)+VALS/2.D0
30632 ENDIF
30633 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30634C nucleon conventions
30635 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30636C neutron valence quarks
30637 DUM = PD(1)
30638 PD(1) = PD(2)
30639 PD(2) = DUM
30640 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30641C (anti-)sigma+
30642 VALS = PD(1)-PD(-1)
30643 PD(1) = PD(-1)
30644 PD(3) = PD(3)+VALS
30645 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30646C (anti-)sigma-
30647 VALS = PD(1)-PD(-1)
30648 VALD = PD(2)-PD(-2)
30649 PD(1) = PD(-1)
30650 PD(2) = PD(-2)
30651 PD(1) = PD(1)+VALD
30652 PD(3) = PD(3)+VALS
30653 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30654 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30655C (anti-)sigma0 and (anti-)lambda
30656 VALS = PD(1)-PD(-1)
30657 VALD = (PD(2)-PD(-2))/2.D0
30658 PD(1) = PD(-1)
30659 PD(2) = PD(-2)
30660 PD(1) = PD(1)+VALD
30661 PD(2) = PD(2)+VALD
30662 PD(3) = PD(3)+VALS
30663 ENDIF
30664 ENDIF
30665
30666C antiparticle
30667 IF(IPARID(NPAR).LT.0) THEN
30668 DO 190 I=1,4
30669 DUM=PD(I)
30670 PD(I)=PD(-I)
30671 PD(-I)=DUM
30672 190 CONTINUE
30673 ENDIF
30674
30675C optionally remove valence quarks
30676 IF(IPAVA(NPAR).EQ.0) THEN
30677 DO 200 I=1,4
30678 PD(I) = MIN(PD(-I),PD(I))
30679 PD(-I) = PD(I)
30680 200 CONTINUE
30681 ENDIF
30682
30683C debug information
30684 IF(IDEB(37).GE.30) WRITE(LO,
30685 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30686 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30687 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30688 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30689
30690 END
30691
30692*$ CREATE PHO_QPMPDF.FOR
30693*COPY PHO_QPMPDF
30694CDECK ID>, PHO_QPMPDF
30695 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30696C***************************************************************
30697C
30698C contribution to photon PDF from box graph
30699C (Bethe-Heitler process)
30700C
30701C input: IQ quark flavour
30702C SCALE2 scale (GeV**2, positive)
30703C PTREF reference scale (GeV, positive)
30704C X parton momentum fraction
30705C PVIRT photon virtuality (GeV**2, positive)
30706C FXP x*f(x,Q**2), x times parton density
30707C
30708C***************************************************************
30709 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30710 SAVE
30711
30712C input/output channels
30713 INTEGER LI,LO
30714 COMMON /POINOU/ LI,LO
30715C event debugging information
30716 INTEGER NMAXD
30717 PARAMETER (NMAXD=100)
30718 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30719 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30720 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30721 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30722C internal rejection counters
30723 INTEGER NMXJ
30724 PARAMETER (NMXJ=60)
30725 CHARACTER*10 REJTIT
30726 INTEGER IFAIL
30727 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30728C some constants
30729 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30730 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30731 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30732
30733 DIMENSION QM(6)
30734 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30735
30736 FXP = 0.D0
30737 I = ABS(IQ)
30738C
30739* QM2 = MAX(QM(I),PTREF)**2
30740* QM2 = MAX(QM2,PVIRT)
30741* BBE = (1.D0-X)*SCALE2
30742* IF(BBE.LE.0.D0) THEN
30743* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30744* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30745* & PVIRT,QM(I)
30746* ENDIF
30747* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30748* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30749C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30750 QM2 = MAX(QM(I),PTREF)**2
30751 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30752 IF(W2.GT.4.D0*QM2) THEN
30753 BE = SQRT(1.D0-4.D0*QM2/W2)
30754 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30755 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30756* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30757 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30758 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30759 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30760 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30761 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30762 ELSE
30763 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30764 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30765 & PVIRT,QM(I)
30766 ENDIF
30767C debug output
30768 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30769 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30770 END
30771
30772*$ CREATE PHO_SETPDF.FOR
30773*COPY PHO_SETPDF
30774CDECK ID>, PHO_SETPDF
30775 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30776C***************************************************************
30777C
30778C assigns PDF numbers to particles
30779C
30780C input: IDPDG PDG number of particle
30781C ITYP particle type
30782C IPAR PDF paramertization
30783C ISET number of set
30784C IEXT library number for PDF calculation
30785C IPAVAL (only output)
30786C 1 PDF with valence quarks
30787C 0 PDF without valence quarks
30788C MODE -1 add entry to table
30789C 1 read from table
30790C 2 output of table
30791C
30792C***************************************************************
30793 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30794 SAVE
30795
30796C input/output channels
30797 INTEGER LI,LO
30798 COMMON /POINOU/ LI,LO
30799C event debugging information
30800 INTEGER NMAXD
30801 PARAMETER (NMAXD=100)
30802 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30803 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30804 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30805 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30806C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30807 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30808 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30809 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30810 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30811
30812 DIMENSION IPDFS(5,50)
30813 DATA IENTRY / 0 /
30814
30815 IF(MODE.EQ.1) THEN
30816 I = 1
30817 IF(IDPDG.EQ.81) THEN
30818 IDCMP = IDEQP(1)
30819 IPAVAL = IHFLS(1)
30820 ELSE IF(IDPDG.EQ.82) THEN
30821 IDCMP = IDEQP(2)
30822 IPAVAL = IHFLS(2)
30823 ELSE
30824 IDCMP = IDPDG
30825 IPAVAL = 1
30826 ENDIF
30827200 CONTINUE
30828 IF(IDCMP.EQ.IPDFS(1,I)) THEN
30829 ITYP = IPDFS(2,I)
30830 IPAR = IPDFS(3,I)
30831 ISET = IPDFS(4,I)
30832 IEXT = IPDFS(5,I)
30833 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30834 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30835 RETURN
30836 ENDIF
30837 I = I+1
30838 IF(I.GT.IENTRY) THEN
30839 WRITE(LO,'(/1X,A,I7)')
30840 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
30841 CALL PHO_ABORT
30842 ENDIF
30843 GOTO 200
30844 ELSE IF(MODE.EQ.-1) THEN
30845 DO 50 I=1,IENTRY
30846 IF(IDPDG.EQ.IPDFS(1,I)) THEN
30847 WRITE(LO,'(/1X,A,5I6)')
30848 & 'PHO_SETPDF: overwrite old particle PDF',
30849 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30850 GOTO 100
30851 ENDIF
30852 50 CONTINUE
30853 I = IENTRY+1
30854 IF(I.GT.50) THEN
30855 WRITE(LO,'(/1X,A,/1x,6I6)')
30856 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
30857 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30858 STOP
30859 ENDIF
30860 IENTRY = I
30861 100 CONTINUE
30862 IPDFS(1,I) = IDPDG
30863 IF(IDPDG.EQ.990) THEN
30864 ITYP1 = 20
30865 ELSE IF(IDPDG.EQ.22) THEN
30866 ITYP1 = 3
30867 ELSE IF(ABS(IDPDG).LT.1000) THEN
30868 ITYP1 = 2
30869 ELSE
30870 ITYP1 = 1
30871 ENDIF
30872 IPDFS(2,I) = ITYP1
30873 IPDFS(3,I) = IPAR
30874 IPDFS(4,I) = ISET
30875 IPDFS(5,I) = IEXT
30876 ELSE IF(MODE.EQ.-2) THEN
30877 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30878 DO 150 I=1,IENTRY
30879 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
30880 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30881 150 CONTINUE
30882 ELSE
30883 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30884 ENDIF
30885 END
30886
30887*$ CREATE PHO_GETPDF.FOR
30888*COPY PHO_GETPDF
30889CDECK ID>, PHO_GETPDF
30890 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30891C***************************************************************
30892C
30893C get PDF information
30894C
30895C input: NPAR 1 first PDF in /POPPDF/
30896C 2 second PDF in /POPPDF/
30897C
30898C output: PDFNA name of PDf parametrization
30899C ALA QCD LAMBDA (4 flavours, in GeV)
30900C Q2MI minimal Q2
30901C Q2MA maximal Q2
30902C XMI minimal X
30903C XMA maximal X
30904C
30905C***************************************************************
30906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30907 SAVE
30908
30909 CHARACTER*8 PDFNA
30910
30911C input/output channels
30912 INTEGER LI,LO
30913 COMMON /POINOU/ LI,LO
30914
30915C PHOLIB 4.15 common
30916 COMMON /W50512/ QCDL4,QCDL5
30917 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30918
30919C PHOPDF version 2.0 common
30920 PARAMETER (MAXS=6,MAXP=10)
30921 CHARACTER*4 CHPAR
30922 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30923 & NSET(MAXP,2),NFL(MAXP)
30924 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30925
30926C currently activated parton density parametrizations
30927 CHARACTER*8 PDFNAM
30928 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30929 DOUBLE PRECISION PDFLAM,PDFQ2M
30930 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30931 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30932
30933 DIMENSION PARAM(20),VALUE(20)
30934 CHARACTER*20 PARAM
30935
30936 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30937 WRITE(LO,'(/1X,A,I6)')
30938 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30939 CALL PHO_ABORT
30940 ENDIF
30941 ALA = 0.D0
30942
30943 IF(IEXT(NPAR).EQ.0) THEN
30944
30945C internal parametrizations
30946
30947 IF(ITYPE(NPAR).EQ.1) THEN
30948C proton PDFs
30949 IF(IGRP(NPAR).EQ.5) THEN
30950 IF(ISET(NPAR).EQ.3) THEN
30951 ALA = 0.2D0
30952 Q2MI = 0.3D0
30953 PDFNA = 'GRV92 HO'
30954 ELSE IF(ISET(NPAR).EQ.4) THEN
30955 ALA = 0.2D0
30956 Q2MI = 0.25D0
30957 PDFNA = 'GRV92 LO'
30958 ELSE IF(ISET(NPAR).EQ.5) THEN
30959 ALA = 0.2D0
30960 Q2MI = 0.4D0
30961 PDFNA = 'GRV94 HO'
30962 ELSE IF(ISET(NPAR).EQ.6) THEN
30963 ALA = 0.2D0
30964 Q2MI = 0.4D0
30965 PDFNA = 'GRV94 LO'
30966 ELSE IF(ISET(NPAR).EQ.7) THEN
30967 ALA = 0.2D0
30968 Q2MI = 0.4D0
30969 PDFNA = 'GRV94 DI'
30970 ELSE IF(ISET(NPAR).EQ.8) THEN
30971 ALA = 0.175D0
30972 Q2MI = 0.8D0
30973 PDFNA = 'GRV98 LO'
30974 ELSE IF(ISET(NPAR).EQ.9) THEN
30975 ALA = 0.175D0
30976 Q2MI = 0.8D0
30977 PDFNA = 'GRV98 SC'
30978 ENDIF
30979 ENDIF
30980 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30981C pion PDFs
30982 IF(IGRP(NPAR).EQ.5) THEN
30983 IF(ISET(NPAR).EQ.1) THEN
30984 ALA = 0.2D0
30985 Q2MI = 0.3D0
30986 PDFNA = 'GRV-P HO'
30987 ELSE IF(ISET(NPAR).EQ.2) THEN
30988 ALA = 0.2D0
30989 Q2MI = 0.25D0
30990 PDFNA = 'GRV-P LO'
30991 ENDIF
30992 ENDIF
30993 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30994C photon PDFs
30995 IF(IGRP(NPAR).EQ.5) THEN
30996 IF(ISET(NPAR).EQ.1) THEN
30997 ALA = 0.2D0
30998 Q2MI = 0.3D0
30999 PDFNA = 'GRV-G LH'
31000 ELSE IF(ISET(NPAR).EQ.2) THEN
31001 ALA = 0.2D0
31002 Q2MI = 0.3D0
31003 PDFNA = 'GRV-G HO'
31004 ELSE IF(ISET(NPAR).EQ.3) THEN
31005 ALA = 0.2D0
31006 Q2MI = 0.25D0
31007 PDFNA = 'GRV-G LO'
31008 ENDIF
31009 ELSE IF(IGRP(NPAR).EQ.8) THEN
31010 IF(ISET(NPAR).EQ.1) THEN
31011 ALA = 0.2D0
31012 Q2MI = 4.D0
31013 PDFNA = 'AGL-G LO'
31014 ENDIF
31015 ENDIF
31016 ELSE IF(ITYPE(NPAR).EQ.20) THEN
31017C pomeron PDFs
31018 IF(IGRP(NPAR).EQ.4) THEN
31019 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31020 ELSE
31021 ALA = 0.3D0
31022 Q2MI = 2.D0
31023 PDFNA = 'POM-PDF1'
31024 ENDIF
31025 ENDIF
31026
31027C external parametrizations
31028
31029 ELSE IF(IEXT(NPAR).EQ.1) THEN
31030C PDFLIB call: old numbering
31031 PARAM(1) = 'MODE'
31032 PARAM(2) = ' '
31033 VALUE(1) = IGRP(NPAR)
31034 CALL PDFSET(PARAM,VALUE)
31035 Q2MI = Q2MIN
31036 Q2MA = Q2MAX
31037 XMI = XMIN
31038 XMA = XMAX
31039 ALA = QCDL4
31040 PDFNA = 'PDFLIB1'
31041 ELSE IF(IEXT(NPAR).EQ.2) THEN
31042C PDFLIB call: new numbering
31043 PARAM(1) = 'NPTYPE'
31044 PARAM(2) = 'NGROUP'
31045 PARAM(3) = 'NSET'
31046 PARAM(4) = ' '
31047 VALUE(1) = ITYPE(NPAR)
31048 VALUE(2) = IGRP(NPAR)
31049 VALUE(3) = ISET(NPAR)
31050 CALL PDFSET(PARAM,VALUE)
31051 Q2MI = Q2MIN
31052 Q2MA = Q2MAX
31053 XMI = XMIN
31054 XMA = XMAX
31055 ALA = QCDL4
31056 PDFNA = 'PDFLIB2'
31057 ELSE IF(IEXT(NPAR).EQ.3) THEN
31058C PHOLIB interface
31059 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31060 Q2MI = 2.D0
31061 PDFNA = CHPAR(IGRP(NPAR))
31062
31063C some special internal parametrizations
31064
31065 ELSE IF(IEXT(NPAR).EQ.4) THEN
31066C photon PDFs depending on virtualities
31067 IF(IGRP(NPAR).EQ.1) THEN
31068C Schuler/Sjostrand parametrization
31069 ALA = 0.2D0
31070 IF(ISET(NPAR).EQ.1) THEN
31071 Q2MI = 0.2D0
31072 PDFNA = 'SaS-1D '
31073 ELSE IF(ISET(NPAR).EQ.2) THEN
31074 Q2MI = 0.2D0
31075 PDFNA = 'SaS-1M '
31076 ELSE IF(ISET(NPAR).EQ.3) THEN
31077 Q2MI = 2.D0
31078 PDFNA = 'SaS-2D '
31079 ELSE IF(ISET(NPAR).EQ.4) THEN
31080 Q2MI = 2.D0
31081 PDFNA = 'SaS-2M '
31082 ENDIF
31083 ELSE IF(IGRP(NPAR).EQ.5) THEN
31084C Gluck/Reya/Stratmann parametrization
31085 IF(ISET(NPAR).EQ.4) THEN
31086 ALA = 0.2D0
31087 Q2MI = 0.6D0
31088 PDFNA = 'GRS-G LO'
31089 ENDIF
31090 ENDIF
31091 ELSE IF(IEXT(NPAR).EQ.5) THEN
31092C Schuler/Sjostrand anomalous only
31093 ALA = 0.2D0
31094 Q2MI = 0.2D0
31095 PDFNA = 'SaS anom'
31096 ENDIF
31097 IF(ALA.LT.0.01D0) THEN
31098 WRITE(LO,'(/1X,2A,/10X,5I6)')
31099 & 'PHO_GETPDF:ERROR: ',
31100 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31101 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31102 CALL PHO_ABORT
31103 ENDIF
31104
31105 END
31106
31107*$ CREATE PHO_ACTPDF.FOR
31108*COPY PHO_ACTPDF
31109CDECK ID>, PHO_ACTPDF
31110 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31111C***************************************************************
31112C
31113C activate PDF for QCD calculations
31114C
31115C input: IDPDG PDG particle number
31116C K 1 first PDF in /POPPDF/
31117C 2 second PDF in /POPPDF/
31118C -2 write current settings
31119C
31120C output: /POPPDF/
31121C
31122C***************************************************************
31123 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31124 SAVE
31125
31126C input/output channels
31127 INTEGER LI,LO
31128 COMMON /POINOU/ LI,LO
31129C event debugging information
31130 INTEGER NMAXD
31131 PARAMETER (NMAXD=100)
31132 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31133 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31134 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31135 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31136C currently activated parton density parametrizations
31137 CHARACTER*8 PDFNAM
31138 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31139 DOUBLE PRECISION PDFLAM,PDFQ2M
31140 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31141 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31142
31143 IF(K.GT.0) THEN
31144
31145C read PDF from table
31146 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31147 & IPAVA(K),1)
31148 IPARID(K) = IDPDG
31149C get PDF parameters
31150 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31151C initialize alpha_s calculation
31152 alam2 = PDFLAM(K)*PDFLAM(K)
31153 DUMMY = PHO_ALPHAS(alam2,-K)
31154
31155 IF(IDEB(2).GE.20) THEN
31156 WRITE(LO,'(1X,A)')
31157 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31158 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31159 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31160 & IEXT(K),IPARID(K)
31161 ENDIF
31162 NPAOLD = K
31163
31164 ELSE IF(K.EQ.-2) THEN
31165
31166C write table of current PDFs
31167 WRITE(LO,'(1X,A)')
31168 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31169 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31170 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31171 & IPARID(1)
31172 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31173 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31174 & IPARID(2)
31175
31176 ELSE
31177
31178 WRITE(LO,'(/1X,A,2I4)')
31179 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31180 CALL PHO_ABORT
31181
31182 ENDIF
31183
31184 END
31185
31186*$ CREATE PHO_PDFTST.FOR
31187*COPY PHO_PDFTST
31188CDECK ID>, PHO_PDFTST
31189 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31190C*********************************************************************
31191C
31192C structure function test utility
31193C
31194C input: IDPDG PDG ID of particle
31195C SCALE2 squared scale (GeV**2)
31196C P2MASS particle virtuality (pos, GeV**2)
31197C
31198C output: tables of PDF, sum rule checking, table of F2
31199C
31200C*********************************************************************
31201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31202 SAVE
31203
31204C input/output channels
31205 INTEGER LI,LO
31206 COMMON /POINOU/ LI,LO
31207C currently activated parton density parametrizations
31208 CHARACTER*8 PDFNAM
31209 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31210 DOUBLE PRECISION PDFLAM,PDFQ2M
31211 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31212 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31213C some constants
31214 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31215 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31216 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31217
31218 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31219 CHARACTER*8 PDFNA
31220
31221 CALL PHO_ACTPDF(IDPDG,1)
31222 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31223
31224 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31225 WRITE(LO,'(A)') ' ======================================='
31226
31227 WRITE(LO,'(/,A,3I10)')
31228 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31229 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31230 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31231 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31232 WRITE(LO,'(/1X,A)') 'x times parton densities'
31233 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31234 WRITE(LO,'(1X,A)')
31235 & ' ============================================================'
31236
31237C logarithmic loop over x values
31238C upper bound
31239 XUPPER=0.9999D0
31240C lower bound
31241 XLOWER=1.D-4
31242C number of steps
31243 NSTEP=50
31244
31245 XFIRST=LOG(XLOWER)
31246 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31247 DO 100 I=1,NSTEP
31248 X=EXP(XFIRST)
31249 XCONTR=X
31250 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31251 IF(X.NE.XCONTR) THEN
31252 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31253 ENDIF
31254 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31255 XFIRST=XFIRST+XDELTA
31256 100 CONTINUE
31257
31258 IF(IDPDG.EQ.22) THEN
31259 WRITE(LO,'(/1X,A)')
31260 & 'comparison PDF to contribution due to box diagram'
31261 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31262 WRITE(LO,'(1X,A)')
31263 & ' ============================================================'
31264 XFIRST=LOG(XLOWER)
31265 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31266 DO 110 I=1,NSTEP
31267 X=EXP(XFIRST)
31268 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31269 DO 120 K=1,4
31270 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31271 120 CONTINUE
31272 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31273 XFIRST=XFIRST+XDELTA
31274 110 CONTINUE
31275 ENDIF
31276
31277C check momentum sum rule
31278
31279 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31280 DO 199 I=-6,6
31281 PDSUM(I) = 0.D0
31282 PDAVE(I) = 0.D0
31283 199 CONTINUE
31284 ITER=5000
31285 DO 200 I=1,ITER
31286 XX=DBLE(I)/DBLE(ITER)
31287 IF(XX.EQ.1.D0) XX = 0.999999D0
31288 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31289 DO 202 K=-6,6
31290 PDSUM(K) = PDSUM(K)+PD(K)/XX
31291 PDAVE(K) = PDAVE(K)+PD(K)
31292 202 CONTINUE
31293 200 CONTINUE
31294 WRITE(LO,'(1X,A)')
31295 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31296 XSUM = 0.D0
31297 DO 204 I=-6,6
31298 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31299 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31300 XSUM = XSUM+PDAVE(I)
31301 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31302 204 CONTINUE
31303 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31304 DO 205 I=1,6
31305 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31306 205 CONTINUE
31307 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31308 WRITE(LO,'(A/)') ' ============================================='
31309
31310C table of F2
31311
31312 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31313 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31314 & '-----------------------------------------------------'
31315 ITER=100
31316 DO 300 I=1,ITER
31317 XX=DBLE(I)/DBLE(ITER)
31318 IF(XX.EQ.1.D0) XX = 0.9999D0
31319 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31320 F2 = 0.D0
31321 DO 302 K=-6,6
31322 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31323 302 CONTINUE
31324 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31325 300 CONTINUE
31326 WRITE(LO,'(A/)') ' ============================================='
31327 END
31328
31329*$ CREATE PHO_REGPAR.FOR
31330*COPY PHO_REGPAR
31331CDECK ID>, PHO_REGPAR
31332 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31333 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31334C**********************************************************************
31335C
31336C registration of particle in /POEVT1/ and /POEVT2/
31337C
31338C input: ISTH status code of particle
31339C -2 initial parton hard scattering
31340C -1 parton
31341C 0 string
31342C 1 visible particle (no color)
31343C 2 decayed particle
31344C IDPDG PDG particle ID code
31345C IDBAM CPC particle ID code
31346C JM1,JM2 first and second mother index
31347C P1..P4 four momentum
31348C IPHIS1 extended history information
31349C IPHIS1<100: JM1 from particle 1
31350C IPHIS1>100: JM1 from particle 2
31351C 1 valence quark
31352C 2 valence diquark
31353C 3 sea quark
31354C 4 sea diquark
31355C (neg. for antipartons)
31356C IPHIS2 extended history information
31357C positive: JM2 from particle 1
31358C negative: JM2 from particle 2
31359C (see IPHIS1)
31360C IC1,IC2 color labels for partons
31361C IMODE 1 register given parton
31362C 0 reset /POEVT1/ and /POEVT2/
31363C 2 return data of entry IPOS
31364C
31365C IPOS position of particle in /POEVT1/
31366C
31367C**********************************************************************
31368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31369 SAVE
31370
31371 PARAMETER (DEPS = 1.D-20)
31372
31373C input/output channels
31374 INTEGER LI,LO
31375 COMMON /POINOU/ LI,LO
31376C event debugging information
31377 INTEGER NMAXD
31378 PARAMETER (NMAXD=100)
31379 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31380 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31381 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31382 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31383C standard particle data interface
31384 INTEGER NMXHEP
31385 PARAMETER (NMXHEP=4000)
31386 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31387 DOUBLE PRECISION PHEP,VHEP
31388 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31389 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31390 & VHEP(4,NMXHEP)
31391C extension to standard particle data interface (PHOJET specific)
31392 INTEGER IMPART,IPHIST,ICOLOR
31393 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31394
31395 IF(IMODE.EQ.1) THEN
31396 IF(IDEB(76).GE.26) THEN
31397 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31398 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31399 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31400 WRITE(LO,'(1X,A,/2X,6I6)')
31401 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31402 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31403 ENDIF
31404 IF(NHEP.EQ.NMXHEP) THEN
31405 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31406 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31407 CALL PHO_ABORT
31408 ENDIF
31409 NHEP = NHEP+1
31410 IDBAMI = IDBAM
31411 IDPDGI = IDPDG
31412 IF(ABS(ISTH).LE.2) THEN
31413 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31414 IDPDGI = ipho_id2pdg(IDBAM)
31415 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31416 IDBAMI = ipho_pdg2id(IDPDG)
31417 ENDIF
31418 ENDIF
31419C standard data
31420 ISTHEP(NHEP) = ISTH
31421 IDHEP(NHEP) = IDPDGI
31422 JMOHEP(1,NHEP) = JM1
31423 JMOHEP(2,NHEP) = JM2
31424C update of mother-daugther relations
31425 IF(ABS(ISTH).LE.1) THEN
31426 IF(JM1.GT.0) THEN
31427 IF(JDAHEP(1,JM1).EQ.0) THEN
31428 JDAHEP(1,JM1) = NHEP
31429 ISTHEP(JM1) = 2
31430 ENDIF
31431 JDAHEP(2,JM1) = NHEP
31432 ENDIF
31433 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31434 IF(JDAHEP(1,JM2).EQ.0) THEN
31435 JDAHEP(1,JM2) = NHEP
31436 ISTHEP(JM2) = 2
31437 ENDIF
31438 JDAHEP(2,JM2) = NHEP
31439 ELSE IF(JM2.LT.0) THEN
31440 DO 100 II=JM1+1,-JM2
31441 IF(JDAHEP(1,II).EQ.0) THEN
31442 JDAHEP(1,II) = NHEP
31443 ISTHEP(II) = 2
31444 ENDIF
31445 JDAHEP(2,II) = NHEP
31446100 CONTINUE
31447 ENDIF
31448 ENDIF
31449 PHEP(1,NHEP) = P1
31450 PHEP(2,NHEP) = P2
31451 PHEP(3,NHEP) = P3
31452 PHEP(4,NHEP) = P4
31453 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31454 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31455 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31456 ELSE
31457 PHEP(5,NHEP) = 0.D0
31458 ENDIF
31459 JDAHEP(1,NHEP) = 0
31460 JDAHEP(2,NHEP) = 0
31461C extended information
31462 IMPART(NHEP) = IDBAMI
31463C extended history information
31464 IPHIST(1,NHEP) = IPHIS1
31465 IPHIST(2,NHEP) = IPHIS2
31466C charge/baryon number or color labels
31467 IF(ISTH.EQ.1) THEN
31468 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31469 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31470 ELSE
31471 ICOLOR(1,NHEP) = IC1
31472 ICOLOR(2,NHEP) = IC2
31473 ENDIF
31474
31475 IPOS = NHEP
31476 IF(IDEB(76).GE.26) THEN
31477 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31478 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31479 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31480 & PHEP(5,NHEP),IPOS
31481 ENDIF
31482
31483 ELSE IF(IMODE.EQ.0) THEN
31484 NHEP = 0
31485 ELSE IF(IMODE.EQ.2) THEN
31486 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31487 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31488 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31489 RETURN
31490 ENDIF
31491 ISTH = ISTHEP(IPOS)
31492 IDPDG = IDHEP(IPOS)
31493 IDBAM = IMPART(IPOS)
31494 JM1 = JMOHEP(1,IPOS)
31495 JM2 = JMOHEP(2,IPOS)
31496 P1 = PHEP(1,IPOS)
31497 P2 = PHEP(2,IPOS)
31498 P3 = PHEP(3,IPOS)
31499 P4 = PHEP(4,IPOS)
31500 IPHIS1= IPHIST(1,IPOS)
31501 IPHIS2= IPHIST(2,IPOS)
31502 IC1 = ICOLOR(1,IPOS)
31503 IC2 = ICOLOR(2,IPOS)
31504 ELSE
31505 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31506 ENDIF
31507 END
31508
31509*$ CREATE IPHO_CNV1.FOR
31510*COPY IPHO_CNV1
31511CDECK ID>, IPHO_CNV1
31512 INTEGER FUNCTION IPHO_CNV1(IPART)
31513C*********************************************************************
31514C
31515C conversion of quark numbering scheme to PARTICLE DATA GROUP
31516C convention
31517C
31518C input: old internal particle code of hard scattering
31519C 0 gluon
31520C 1 d
31521C 2 u
31522C 3 s
31523C 4 c
31524C valence quarks changed to standard numbering
31525C
31526C output: standard particle codes
31527C
31528C*********************************************************************
31529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31530 SAVE
31531C
31532 II = ABS(IPART)
31533C change gluon number
31534 IF(II.EQ.0) THEN
31535 IPHO_CNV1 = 21
31536C change valence quark
31537 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31538 IPHO_CNV1 = SIGN(II-6,IPART)
31539 ELSE
31540 IPHO_CNV1 = IPART
31541 ENDIF
31542 END
31543
31544*$ CREATE PHO_HACODE.FOR
31545*COPY PHO_HACODE
31546CDECK ID>, PHO_HACODE
31547 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31548C*********************************************************************
31549C
31550C determination of hadron index from quarks
31551C
31552C input: ID1,ID2 parton code according to PDG conventions
31553C
31554C output: IDcpc1,2 CPC particle codes
31555C
31556C*********************************************************************
31557 IMPLICIT NONE
31558 SAVE
31559
31560 integer ID1,ID2,IDcpc1,IDcpc2
31561
31562C input/output channels
31563 INTEGER LI,LO
31564 COMMON /POINOU/ LI,LO
31565C event debugging information
31566 INTEGER NMAXD
31567 PARAMETER (NMAXD=100)
31568 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31569 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31570 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31571 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31572C general particle data
31573 double precision xm_list,tau_list,gam_list,
31574 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31575 & xm_bb82_list,xm_bb102_list
31576 integer ich3_list,iba3_list,iq_list,
31577 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31578 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31579 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31580 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31581 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31582 & ich3_list(300),iba3_list(300),iq_list(3,300),
31583 & id_psm_list(6,6),id_vem_list(6,6),
31584 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31585
31586C local variables
31587 integer ii,jj,kk,i1,i2
31588
31589 IDcpc1 = 0
31590 IDcpc2 = 0
31591
31592 if(ID1*ID2.lt.0) then
31593C meson
31594 if(ID1.gt.0) then
31595 ii = ID1
31596 jj = -ID2
31597 else
31598 ii = ID2
31599 jj = -ID1
31600 endif
31601 IDcpc1 = ID_psm_list(ii,jj)
31602 IDcpc2 = ID_vem_list(ii,jj)
31603
31604 else
31605C baryon
31606 i1 = abs(ID1)
31607 i2 = abs(ID2)
31608 if(i1.gt.6) then
31609 ii = i1/1000
31610 jj = (i1-ii*1000)/100
31611 kk = i2
31612 else
31613 ii = i1
31614 jj = i2/1000
31615 kk = (i2-jj*1000)/100
31616 endif
31617 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31618 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31619
31620 endif
31621
31622 END
31623
31624*$ CREATE PHO_ID2STR.FOR
31625*COPY PHO_ID2STR
31626CDECK ID>, PHO_ID2STR
31627 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31628C*********************************************************************
31629C
31630C conversion of quark numbering scheme
31631C
31632C input: standard particle codes:
31633C ID1
31634C ID2
31635C
31636C output: NOBAM CPC string code
31637C quark codes (PDG convention):
31638C IBAM1
31639C IBAM2
31640C IBAM3
31641C IBAM4
31642C
31643C NOBAM = -1 invalid flavour combinations
31644C
31645C*********************************************************************
31646 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31647 SAVE
31648
31649C input/output channels
31650 INTEGER LI,LO
31651 COMMON /POINOU/ LI,LO
31652
31653 IDA1 = ABS(ID1)
31654 IDA2 = ABS(ID2)
31655
31656C quark-antiquark string
31657 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31658 IF((ID1*ID2).GE.0) GOTO 100
31659 IBAM1 = ID1
31660 IBAM2 = ID2
31661 IBAM3 = 0
31662 IBAM4 = 0
31663 NOBAM = 3
31664C quark-diquark string
31665 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31666 IF((ID1*ID2).LE.0) GOTO 100
31667 IBAM1 = ID1
31668 IBAM2 = ID2/1000
31669 IBAM3 = (ID2-IBAM2*1000)/100
31670 IBAM4 = 0
31671 NOBAM = 4
31672C diquark-quark string
31673 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31674 IF((ID1*ID2).LE.0) GOTO 100
31675 IBAM1 = ID1/1000
31676 IBAM2 = (ID1-IBAM1*1000)/100
31677 IBAM3 = ID2
31678 IBAM4 = 0
31679 NOBAM = 6
31680C gluon-gluon string
31681 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31682 IBAM1 = 21
31683 IBAM2 = 21
31684 IBAM3 = 0
31685 IBAM4 = 0
31686 NOBAM = 7
31687C diquark-antidiquark string
31688 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31689 IF((ID1*ID2).GE.0) GOTO 100
31690 IBAM1 = ID1/1000
31691 IBAM2 = (ID1-IBAM1*1000)/100
31692 IBAM3 = ID2/1000
31693 IBAM4 = (ID2-IBAM3*1000)/100
31694 NOBAM = 5
31695 ENDIF
31696 RETURN
31697
31698C invalid combination
31699 100 CONTINUE
31700 WRITE(LO,'(//1X,A,2I10)')
31701 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31702 CALL PHO_ABORT
31703
31704 END
31705
31706*$ CREATE PHO_MKSLTR.FOR
31707*COPY PHO_MKSLTR
31708CDECK ID>, PHO_MKSLTR
31709 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31710C********************************************************************
31711C
31712C calculate successive Lorentz boots for arbitrary Lorentz trans.
31713C
31714C input: P1 initial 4 vector
31715C GAM(3),GAMB(3) Lorentz boost parameters
31716C
31717C output: P2 final 4 vector
31718C
31719C********************************************************************
31720 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31721 SAVE
31722
31723 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31724
31725 P2(4) = P1(4)
31726 DO 150 I=1,3
31727 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31728 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31729 150 CONTINUE
31730 END
31731
31732*$ CREATE PHO_GETLTR.FOR
31733*COPY PHO_GETLTR
31734CDECK ID>, PHO_GETLTR
31735 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31736C********************************************************************
31737C
31738C calculate Lorentz boots for arbitrary Lorentz transformation
31739C
31740C input: P1 initial 4 vector
31741C P2 final 4 vector
31742C
31743C output: GAM(3),GAMB(3)
31744C DELE energy deviation
31745C IREJ 0 success
31746C 1 failure
31747C
31748C********************************************************************
31749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31750 SAVE
31751
31752 PARAMETER ( DREL = 0.001D0 )
31753
31754C input/output channels
31755 INTEGER LI,LO
31756 COMMON /POINOU/ LI,LO
31757
31758 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31759
31760 IREJ = 1
31761 DO 50 K=1,4
31762 PA(K) = P1(K)
31763 PP(K) = P1(K)
31764 50 CONTINUE
31765 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31766 DO 100 I=1,3
31767 PP(I) = P2(I)
31768 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31769 IF(PP(4).LE.0.D0) RETURN
31770 PP(4) = SQRT(PP(4))
31771 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31772 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31773 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31774 GAMB(I) = GAMB(I)*GAM(I)
31775 DO 150 K=1,4
31776 PA(K) = PP(K)
31777 150 CONTINUE
31778 100 CONTINUE
31779 DELE = P2(4)-PP(4)
31780 IREJ = 0
31781C consistency check
31782* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31783* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31784* WRITE(LO,'(/1X,A,2E12.5)')
31785* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31786* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31787* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31788* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31789* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31790* ENDIF
31791 END
31792
31793*$ CREATE PHO_ALTRA.FOR
31794*COPY PHO_ALTRA
31795CDECK ID>, PHO_ALTRA
31796 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31797C*********************************************************************
31798C
31799C arbitrary Lorentz transformation
31800C
31801C*********************************************************************
31802 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31803 SAVE
31804
31805 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31806 PE=EP/(GA+1.D0)+EC
31807 PX=PCX+BGX*PE
31808 PY=PCY+BGY*PE
31809 PZ=PCZ+BGZ*PE
31810 P=SQRT(PX*PX+PY*PY+PZ*PZ)
31811 E=GA*EC+EP
31812
31813 END
31814
31815*$ CREATE PHO_LTRANS.FOR
31816*COPY PHO_LTRANS
31817CDECK ID>, PHO_LTRANS
31818 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31819 & PL,CXL,CYL,CZL,EL)
31820C**********************************************************************
31821C
31822C Lorentz transformation into lab - system
31823C
31824C**********************************************************************
31825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31826 SAVE
31827
31828 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31829
31830C input/output channels
31831 INTEGER LI,LO
31832 COMMON /POINOU/ LI,LO
31833
31834 SID=SQRT(1.D0-COD*COD)
31835 PLX=P*SID*COF
31836 PLY=P*SID*SIF
31837 PCMZ=P*COD
31838 PLZ=GAM*PCMZ+BGAM*ECM
31839 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31840 EL=GAM*ECM+BGAM*PCMZ
31841
31842C rotation into the original direction
31843 COZ=PLZ/PL
31844 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31845
31846* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31847
31848 AX=ABS(CX)
31849 AY=ABS(CY)
31850 IF(AX.LT.AY) THEN
31851 AMAX=AY
31852 AMIN=AX
31853 ELSE
31854 AMAX=AX
31855 AMIN=AY
31856 ENDIF
31857 IF (ABS(CX)-TINY) 1,1,2
31858 1 IF (ABS(CY)-TINY) 3,3,2
31859
31860 3 CONTINUE
ecf67adb 31861* WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
9aaba0d6 31862 CXL=SIZ*COF
31863 CYL=SIZ*SIF
31864 CZL=COZ*CZ
ecf67adb 31865* WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
9aaba0d6 31866* WRITE(LO,*) CXL,CYL,CZL
31867 RETURN
31868
31869 2 CONTINUE
31870 IF(AMAX.GT.TINY2) THEN
31871 AR=AMIN/AMAX
31872 AR=AR*AR
31873 A=AMAX*SQRT(1.D0+AR)
31874 ELSE
ecf67adb 31875* WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
9aaba0d6 31876 GOTO 3
31877 ENDIF
31878 XI=SIZ*COF
31879 YI=SIZ*SIF
31880 ZI=COZ
31881 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31882 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31883 CZL=A*YI+CZ*ZI
31884
31885 END
31886
31887*$ CREATE PHO_TRANS.FOR
31888*COPY PHO_TRANS
31889CDECK ID>, PHO_TRANS
31890 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31891C**********************************************************************
31892C
31893C rotation of coordinate frame (1) de rotation around y axis
31894C (2) fe rotation around z axis
31895C (inverse rotation to PHO_TRANI)
31896C
31897C**********************************************************************
31898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31899 SAVE
31900
31901 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31902 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31903 Z=-SDE *XO +CDE *ZO
31904
31905 END
31906
31907*$ CREATE PHO_TRANI.FOR
31908*COPY PHO_TRANI
31909CDECK ID>, PHO_TRANI
31910 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31911C**********************************************************************
31912C
31913C rotation of coordinate frame (1) -fe rotation around z axis
31914C (2) -de rotation around y axis
31915C (inverse rotation to PHO_TRANS)
31916C
31917C**********************************************************************
31918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31919 SAVE
31920
31921 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31922 Y=-SFE *XO+CFE* YO
31923 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31924
31925 END
31926
31927*$ CREATE pho_cpcini.FOR
31928*COPY pho_cpcini
31929CDECK ID>, pho_cpcini
31930 SUBROUTINE pho_cpcini(Nrows,Number,List)
31931C***********************************************************************
31932C
31933C initialization of particle hash table
31934C
31935C input: Number vector with Nrows entries according to PDG
31936C convention
31937C
31938C output: List vector with hash table
31939C
31940C (this code is based on the function initpns written by
31941C Gerry Lynch, LBL, January 1990)
31942C
31943C***********************************************************************
31944 IMPLICIT NONE
31945 SAVE
31946
31947C input/output channels
31948 INTEGER LI,LO
31949 COMMON /POINOU/ LI,LO
31950
31951 integer Number(*),List(*),Nrows
31952
31953 Integer Nin,Nout,Ip,I
31954
31955 do I = 1,577
31956 List(I) = 0
31957 enddo
31958
31959C Loop over all of the elements in the Number vector
31960
31961 Do 500 Ip = 1,Nrows
31962 Nin = Number(Ip)
31963
31964C Calculate a list number for this particle id number
31965 If(Nin.Gt.99999.or.Nin.Le.0) Then
31966 Nout = -1
31967 Else If(Nin.Le.577) Then
31968 Nout = Nin
31969 Else
31970 Nout = Mod(Nin,577)
31971 End If
31972
31973 200 continue
31974
31975 If(Nout.Lt.0) Then
31976C Count the bad entries
31977 WRITE(LO,'(1x,a,i10)')
31978 & 'pho_cpcini: invalid particle ID',Nin
31979 Go to 500
31980 End If
31981 If(List(Nout).eq.0) Then
31982 List(Nout) = Ip
31983 Else
31984 If(Nin.eq.Number(List(Nout))) Then
31985 WRITE(LO,'(1x,a,i10)')
31986 & 'pho_cpcini: double particle ID',Nin
31987 End If
31988 Nout = Nout + 5
31989 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31990
31991 Go to 200
31992 End If
31993 500 Continue
31994
31995 END
31996
31997*$ CREATE ipho_pdg2id.FOR
31998*COPY ipho_pdg2id
31999CDECK ID>, ipho_pdg2id
32000 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32001C**********************************************************************
32002C
32003C calculation internal particle code using the particle index i
32004C according to the PDG proposal.
32005C
32006C input: IDpdg PDG particle number
32007C output: ipho_pdg2id internal particle code
32008C (0 for invalid IDpdg)
32009C
32010C the hash algorithm is based on a program by Gerry Lynch
32011C
32012C**********************************************************************
32013 IMPLICIT NONE
32014 SAVE
32015
32016 integer IDpdg
32017
32018C input/output channels
32019 INTEGER LI,LO
32020 COMMON /POINOU/ LI,LO
32021C event debugging information
32022 INTEGER NMAXD
32023 PARAMETER (NMAXD=100)
32024 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32025 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32026 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32027 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32028C particle ID translation table
32029 integer ID_pdg_list,ID_list,ID_pdg_max
32030 character*12 name_list
32031 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32032 & ID_pdg_max
32033
32034 integer Nin,Nout
32035
32036 Nin = abs(IDpdg)
32037
32038 if((Nin.gt.99999).or.(Nin.eq.0)) then
32039C invalid particle number
32040 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32041 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32042 ipho_pdg2id = 0
32043 return
32044 else If(Nin.le.577) then
32045C simple case
32046 Nout = Nin
32047 else
32048C use hash algorithm
32049 Nout = mod(Nin,577)
32050 endif
32051
32052 100 continue
32053
32054C particle not in table
32055 if(ID_list(Nout).Eq.0) then
32056 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32057 & 'ipho_pdg2id: particle not in table ',IDpdg
32058 ipho_pdg2id = 0
32059 return
32060 endif
32061
32062 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32063C particle ID found
32064 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32065 return
32066 else
32067C increment and try again
32068 Nout = Nout + 5
32069 If(Nout.gt.577) Nout = Mod(Nout,577)
32070 goto 100
32071 endif
32072
32073 END
32074
32075*$ CREATE IPHO_ID2PDG.FOR
32076*COPY IPHO_ID2PDG
32077CDECK ID>, IPHO_ID2PDG
32078 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32079C**********************************************************************
32080C
32081C conversion of internal particle code to PDG standard
32082C
32083C input: IDcpc internal particle number
32084C output: ipho_id2pdg PDG particle number
32085C (0 for invalid IDcpc)
32086C
32087C**********************************************************************
32088 IMPLICIT NONE
32089 SAVE
32090
32091 integer IDcpc
32092
32093C input/output channels
32094 INTEGER LI,LO
32095 COMMON /POINOU/ LI,LO
32096C event debugging information
32097 INTEGER NMAXD
32098 PARAMETER (NMAXD=100)
32099 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32100 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32101 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32102 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32103C particle ID translation table
32104 integer ID_pdg_list,ID_list,ID_pdg_max
32105 character*12 name_list
32106 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32107 & ID_pdg_max
32108
32109 integer IDabs
32110
32111 IDabs = abs(IDcpc)
32112 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32113 ipho_id2pdg = 0
32114 return
32115 endif
32116
32117 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32118
32119 END
32120
32121*$ CREATE IPHO_LU2PDG.FOR
32122*COPY IPHO_LU2PDG
32123CDECK ID>, IPHO_LU2PDG
32124 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32125C**********************************************************************
32126C
32127C conversion of JETSET KF code to PDG code
32128C
32129C**********************************************************************
32130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32131 SAVE
32132 PARAMETER (NTAB=10)
32133 DIMENSION LU2PD(2,NTAB)
32134 DATA LU2PD / 4232, 4322,
32135 & 4322, 4232,
32136 & 3212, 3122,
32137 & 3122, 3212,
32138 & 30553, 20553,
32139 & 30443, 20443,
32140 & 20443, 10443,
32141 & 10443, 0,
32142 & 511, 0,
32143 & 10551, 551 /
32144C
32145 DO 100 I=1,NTAB
32146 IF(LU2PD(1,I).EQ.LUKF) THEN
32147 IPHO_LU2PDG=LU2PD(2,I)
32148 RETURN
32149 ENDIF
32150 100 CONTINUE
32151 IPHO_LU2PDG=LUKF
32152
32153 END
32154
32155*$ CREATE IPHO_PDG2LU.FOR
32156*COPY IPHO_PDG2LU
32157CDECK ID>, IPHO_PDG2LU
32158 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32159C**********************************************************************
32160C
32161C conversion of PDG code to JETSET code
32162C
32163C**********************************************************************
32164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32165 SAVE
32166 PARAMETER (NTAB=8)
32167 DIMENSION LU2PD(2,NTAB)
32168 DATA LU2PD / 4232, 4322,
32169 & 4322, 4232,
32170 & 3212, 3122,
32171 & 3122, 3212,
32172 & 30553, 20553,
32173 & 30443, 20443,
32174 & 20443, 10443,
32175 & 10551, 551 /
32176C
32177 DO 100 I=1,NTAB
32178 IF(LU2PD(2,I).EQ.IPDG) THEN
32179 IPHO_PDG2LU=LU2PD(1,I)
32180 RETURN
32181 ENDIF
32182 100 CONTINUE
32183 IPHO_PDG2LU=IPDG
32184
32185 END
32186
32187*$ CREATE pho_pname.FOR
32188*COPY pho_pname
32189CDECK ID>, pho_pname
32190 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32191C***********************************************************************
32192C
32193C returns particle name for given ID number
32194C
32195C input: ID particle ID number
32196C mode 0: ID treated as compressed particle code
32197C 1: ID treated as PDG number
32198C
32199C***********************************************************************
32200 IMPLICIT NONE
32201 SAVE
32202
32203 integer ID,mode
32204
32205C input/output channels
32206 INTEGER LI,LO
32207 COMMON /POINOU/ LI,LO
32208C standard particle data interface
32209 INTEGER NMXHEP
32210 PARAMETER (NMXHEP=4000)
32211 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32212 DOUBLE PRECISION PHEP,VHEP
32213 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32214 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32215 & VHEP(4,NMXHEP)
32216C extension to standard particle data interface (PHOJET specific)
32217 INTEGER IMPART,IPHIST,ICOLOR
32218 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32219C particle ID translation table
32220 integer ID_pdg_list,ID_list,ID_pdg_max
32221 character*12 name_list
32222 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32223 & ID_pdg_max
32224C general particle data
32225 double precision xm_list,tau_list,gam_list,
32226 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32227 & xm_bb82_list,xm_bb102_list
32228 integer ich3_list,iba3_list,iq_list,
32229 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32230 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32231 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32232 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32233 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32234 & ich3_list(300),iba3_list(300),iq_list(3,300),
32235 & id_psm_list(6,6),id_vem_list(6,6),
32236 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32237
32238C external functions
32239 integer ipho_id2pdg,ipho_pdg2id
32240
32241C local variables
32242 integer IDpdg,i,ii,k,l,ichar,i_anti
32243 character*15 name
32244
32245 pho_pname = '(?????????????)'
32246
32247 if(mode.eq.0) then
32248 i = ID
32249 IDpdg = ipho_id2pdg(ID)
32250 if(IDpdg.eq.0) return
32251 else if(mode.eq.1) then
32252 i = ipho_pdg2id(ID)
32253 if(i.eq.0) return
32254 IDpdg = ID
32255 else if(mode.eq.2) then
32256 if(ISTHEP(ID).gt.11) then
32257 if(ISTHEP(ID).eq.20) then
32258 pho_pname = 'hard ini. part.'
32259 else if(ISTHEP(ID).eq.21) then
32260 pho_pname = 'hard fin. part.'
32261 else if(ISTHEP(ID).eq.25) then
32262 pho_pname = 'hard scattering'
32263 else if(ISTHEP(ID).eq.30) then
32264 pho_pname = 'diff. diss. '
32265 else if(ISTHEP(ID).eq.35) then
32266 pho_pname = 'elastic scatt. '
32267 else if(ISTHEP(ID).eq.40) then
32268 pho_pname = 'central scatt. '
32269 endif
32270 return
32271 endif
32272 IDpdg = IDHEP(ID)
32273 i = IMPART(ID)
32274 else
32275 WRITE(LO,'(1x,a,2i4)')
32276 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32277 return
32278 endif
32279
32280 ii = abs(i)
32281 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32282
32283 name = name_list(ii)
32284 ichar = ich3_list(ii)*sign(1,i)
32285 if(mod(ichar,3).ne.0) then
32286 ichar = 0
32287 else
32288 ichar = ichar/3
32289 endif
32290
32291C find position of first blank character
32292 k = 1
32293 100 continue
32294 k = k+1
32295 if(name(k:k).ne.' ') goto 100
32296
32297C append anti-particle sign
32298 if(i.lt.0) then
32299 i_anti = 0
32300 do l=1,3
32301 i_anti = i_anti+iq_list(l,ii)
32302 enddo
32303 if(iba3_list(ii).ne.0) then
32304 name(k:k) = '~'
32305 k = K+1
32306 else if(((i_anti.ne.0).and.(ichar.eq.0))
32307 & .or.(IDpdg.eq.-12)
32308 & .or.(IDpdg.eq.-14)
32309 & .or.(IDpdg.eq.-16)) then
32310 name(k:k) = '~'
32311 k = K+1
32312 endif
32313 endif
32314
32315C append charge sign
32316 if(ichar.eq.-2) then
32317 name(k:k+1) = '--'
32318 else if(ichar.eq.-1) then
32319 name(k:k) = '-'
32320 else if(ichar.eq.1) then
32321 name(k:k) = '+'
32322 else if(ichar.eq.2) then
32323 name(k:k+1) = '++'
32324 endif
32325
32326 pho_pname = name
32327
32328 END
32329
32330*$ CREATE ipho_anti.FOR
32331*COPY ipho_anti
32332CDECK ID>, ipho_anti
32333 INTEGER FUNCTION ipho_anti(ID)
32334C**********************************************************************
32335C
32336C determine antiparticle for given ID
32337C
32338C input: ID gives CPC particle number
32339C
32340C output: ipho_anti antiparticle code
32341C
32342C**********************************************************************
32343 IMPLICIT NONE
32344 SAVE
32345
32346 integer ID
32347
32348C input/output channels
32349 INTEGER LI,LO
32350 COMMON /POINOU/ LI,LO
32351C event debugging information
32352 INTEGER NMAXD
32353 PARAMETER (NMAXD=100)
32354 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32355 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32356 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32357 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32358C particle ID translation table
32359 integer ID_pdg_list,ID_list,ID_pdg_max
32360 character*12 name_list
32361 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32362 & ID_pdg_max
32363C general particle data
32364 double precision xm_list,tau_list,gam_list,
32365 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32366 & xm_bb82_list,xm_bb102_list
32367 integer ich3_list,iba3_list,iq_list,
32368 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32369 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32370 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32371 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32372 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32373 & ich3_list(300),iba3_list(300),iq_list(3,300),
32374 & id_psm_list(6,6),id_vem_list(6,6),
32375 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32376C standard particle data interface
32377 INTEGER NMXHEP
32378 PARAMETER (NMXHEP=4000)
32379 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32380 DOUBLE PRECISION PHEP,VHEP
32381 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32382 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32383 & VHEP(4,NMXHEP)
32384C extension to standard particle data interface (PHOJET specific)
32385 INTEGER IMPART,IPHIST,ICOLOR
32386 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32387
32388C external functions
32389 integer ipho_id2pdg,ipho_pdg2id
32390
32391C local variables
32392 integer IDabs,IDpdg,i_anti,l
32393
32394 ipho_anti = -ID
32395 IDabs = abs(ID)
32396
32397C baryons
32398 if(iba3_list(IDabs).ne.0) return
32399
32400C charged particles
32401 if(ich3_list(IDabs).ne.0) return
32402
32403C K0_s and K0_l
32404 IDpdg = ipho_id2pdg(ID)
32405 if(IDpdg.eq.310) then
32406 ID = ipho_pdg2id(130)
32407 return
32408 else if(IDpdg.eq.130) then
32409 ID = ipho_pdg2id(310)
32410 return
32411 endif
32412
32413C neutral mesons with open strangeness, charm, or beauty
32414 i_anti = 0
32415 do l=1,3
32416 i_anti = i_anti+iq_list(l,IDabs)
32417 enddo
32418 if(i_anti.ne.0) return
32419
32420C neutrinos
32421 IDpdg = abs(IDpdg)
32422 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32423
32424 ipho_anti = ID
32425
32426 END
32427
32428*$ CREATE ipho_chr3.FOR
32429*COPY ipho_chr3
32430CDECK ID>, ipho_chr3
32431 INTEGER FUNCTION ipho_chr3(ID,mode)
32432C**********************************************************************
32433C
32434C output of three times the electric charge
32435C
32436C input: mode
32437C 0 ID gives CPC particle number
32438C 1 ID gives PDG particle number
32439C 2 ID gives position of particle in /POEVT1/
32440C
32441C**********************************************************************
32442 IMPLICIT NONE
32443 SAVE
32444
32445 integer ID,mode
32446
32447C input/output channels
32448 INTEGER LI,LO
32449 COMMON /POINOU/ LI,LO
32450C event debugging information
32451 INTEGER NMAXD
32452 PARAMETER (NMAXD=100)
32453 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32454 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32455 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32456 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32457C standard particle data interface
32458 INTEGER NMXHEP
32459 PARAMETER (NMXHEP=4000)
32460 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32461 DOUBLE PRECISION PHEP,VHEP
32462 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32463 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32464 & VHEP(4,NMXHEP)
32465C extension to standard particle data interface (PHOJET specific)
32466 INTEGER IMPART,IPHIST,ICOLOR
32467 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32468C particle ID translation table
32469 integer ID_pdg_list,ID_list,ID_pdg_max
32470 character*12 name_list
32471 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32472 & ID_pdg_max
32473C general particle data
32474 double precision xm_list,tau_list,gam_list,
32475 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32476 & xm_bb82_list,xm_bb102_list
32477 integer ich3_list,iba3_list,iq_list,
32478 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32479 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32480 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32481 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32482 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32483 & ich3_list(300),iba3_list(300),iq_list(3,300),
32484 & id_psm_list(6,6),id_vem_list(6,6),
32485 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32486
32487C external functions
32488 integer ipho_pdg2id
32489
32490C local variables
32491 integer i,IDpdg
32492
32493 ipho_chr3 = 0
32494
32495 if(mode.eq.0) then
32496 i = ID
32497 else if(mode.eq.1) then
32498 i = ipho_pdg2id(ID)
32499 if(i.eq.0) return
32500 IDpdg = ID
32501 else if(mode.eq.2) then
32502 if(ISTHEP(ID).gt.11) return
32503 i = IMPART(ID)
32504 IDpdg = IDHEP(ID)
32505 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32506 ipho_chr3 = ICOLOR(1,ID)
32507 return
32508 endif
32509 else
32510 WRITE(LO,'(1x,a,2i4)')
32511 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32512 return
32513 endif
32514
32515 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32516 WRITE(LO,'(1x,a,3i8)')
32517 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32518 ipho_chr3 = 1.D0/dble(i)
32519 call pho_prevnt(0)
32520 return
32521 endif
32522
32523 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32524
32525 END
32526
32527*$ CREATE ipho_bar3.FOR
32528*COPY ipho_bar3
32529CDECK ID>, ipho_bar3
32530 INTEGER FUNCTION ipho_bar3(ID,mode)
32531C**********************************************************************
32532C
32533C output of three times the baryon charge
32534C
32535C index: MODE
32536C 0 ID gives CPC particle number
32537C 1 ID gives PDG particle number
32538C 2 ID gives position of particle in /POEVT1/
32539C
32540C**********************************************************************
32541 IMPLICIT NONE
32542 SAVE
32543
32544 integer ID,mode
32545
32546C input/output channels
32547 INTEGER LI,LO
32548 COMMON /POINOU/ LI,LO
32549C event debugging information
32550 INTEGER NMAXD
32551 PARAMETER (NMAXD=100)
32552 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32553 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32554 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32555 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32556C standard particle data interface
32557 INTEGER NMXHEP
32558 PARAMETER (NMXHEP=4000)
32559 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32560 DOUBLE PRECISION PHEP,VHEP
32561 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32562 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32563 & VHEP(4,NMXHEP)
32564C extension to standard particle data interface (PHOJET specific)
32565 INTEGER IMPART,IPHIST,ICOLOR
32566 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32567C particle ID translation table
32568 integer ID_pdg_list,ID_list,ID_pdg_max
32569 character*12 name_list
32570 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32571 & ID_pdg_max
32572C general particle data
32573 double precision xm_list,tau_list,gam_list,
32574 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32575 & xm_bb82_list,xm_bb102_list
32576 integer ich3_list,iba3_list,iq_list,
32577 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32578 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32579 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32580 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32581 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32582 & ich3_list(300),iba3_list(300),iq_list(3,300),
32583 & id_psm_list(6,6),id_vem_list(6,6),
32584 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32585
32586C external functions
32587 integer ipho_pdg2id
32588
32589C local variables
32590 integer i,IDpdg
32591
32592 ipho_bar3 = 0
32593
32594 if(mode.eq.0) then
32595 i = ID
32596 else if(mode.eq.1) then
32597 i = ipho_pdg2id(ID)
32598 if(i.eq.0) return
32599 IDpdg = ID
32600 else if(mode.eq.2) then
32601 if(ISTHEP(ID).gt.11) return
32602 i = IMPART(ID)
32603 IDpdg = IDHEP(ID)
32604 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32605 ipho_bar3 = ICOLOR(2,ID)
32606 return
32607 endif
32608 else
32609 WRITE(LO,'(1x,a,2i4)')
32610 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32611 return
32612 endif
32613
32614 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32615 WRITE(LO,'(1x,a,3i8)')
32616 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32617 ipho_bar3 = 1.D0/dble(i)
32618 return
32619 endif
32620
32621 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32622
32623 END
32624
32625*$ CREATE pho_pmass.FOR
32626*COPY pho_pmass
32627CDECK ID>, pho_pmass
32628 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32629C***********************************************************************
32630C
32631C particle mass
32632C
32633C input: mode -1 initialization
32634C 0 ID gives CPC particle number
32635C 1 ID gives PDG particle number,
32636C (for quarks current masses are returned)
32637C 2 ID gives position of particle in /POEVT1/
32638C 3 ID gives PDG parton number,
32639C (for quarks constituent masses are returned)
32640C
32641C output: average particle mass (in GeV)
32642C
32643C***********************************************************************
32644 IMPLICIT NONE
32645 SAVE
32646
32647 integer ID,mode,MSTJ24
32648
32649C input/output channels
32650 INTEGER LI,LO
32651 COMMON /POINOU/ LI,LO
32652C event debugging information
32653 INTEGER NMAXD
32654 PARAMETER (NMAXD=100)
32655 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32656 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32657 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32658 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32659C model switches and parameters
32660 CHARACTER*8 MDLNA
32661 INTEGER ISWMDL,IPAMDL
32662 DOUBLE PRECISION PARMDL
32663 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32664C standard particle data interface
32665 INTEGER NMXHEP
32666 PARAMETER (NMXHEP=4000)
32667 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32668 DOUBLE PRECISION PHEP,VHEP
32669 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32670 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32671 & VHEP(4,NMXHEP)
32672C extension to standard particle data interface (PHOJET specific)
32673 INTEGER IMPART,IPHIST,ICOLOR
32674 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32675C particle ID translation table
32676 integer ID_pdg_list,ID_list,ID_pdg_max
32677 character*12 name_list
32678 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32679 & ID_pdg_max
32680C general particle data
32681 double precision xm_list,tau_list,gam_list,
32682 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32683 & xm_bb82_list,xm_bb102_list
32684 integer ich3_list,iba3_list,iq_list,
32685 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32686 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32687 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32688 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32689 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32690 & ich3_list(300),iba3_list(300),iq_list(3,300),
32691 & id_psm_list(6,6),id_vem_list(6,6),
32692 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32693 INTEGER MSTU,MSTJ
32694 DOUBLE PRECISION PARU,PARJ
32695 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32696
32697C external functions
32698 integer ipho_pdg2id,ipho_id2pdg
32699 DOUBLE PRECISION PYMASS
32700
32701C local variables
32702 integer i,IDpdg
32703
32704 pho_pmass = 0.D0
32705
32706 if(mode.eq.0) then
32707 i = ID
32708 else if(mode.eq.1) then
32709 i = ipho_pdg2id(ID)
32710 if(i.eq.0) return
32711 else if(mode.eq.2) then
32712 if(ISTHEP(ID).gt.11) return
32713 i = IMPART(ID)
32714 IDpdg = IDHEP(ID)
32715 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32716 pho_pmass = PHEP(5,ID)
32717 return
32718 endif
32719 else if(mode.eq.3) then
32720 i = abs(ID)
32721 if((i.gt.0).and.(i.le.6)) then
32722 pho_pmass = PARMDL(150+i)
32723 return
32724 else
32725 i = ipho_pdg2id(ID)
32726 if(i.eq.0) return
32727 endif
32728 else if(mode.eq.-1) then
32729C initialization: take masses for quarks and di-quarks from JETSET
32730 MSTJ24 = MSTJ(24)
32731 MSTJ(24) = 0
32732 do i=1,22
32733 IDpdg = ipho_id2pdg(i)
32734 xm_list(i) = PYMASS(IDpdg)
32735 enddo
32736 MSTJ(24) = MSTJ24
32737 return
32738 else
32739 WRITE(LO,'(1x,a,2i4)')
32740 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32741 return
32742 endif
32743
32744 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32745 WRITE(LO,'(1x,a,2i8)')
32746 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32747 pho_pmass = 1.D0/dble(i)
32748 return
32749 endif
32750
32751 pho_pmass = xm_list(iabs(i))
32752
32753 END
32754
32755*$ CREATE PHO_MEMASS.FOR
32756*COPY PHO_MEMASS
32757CDECK ID>, PHO_MEMASS
32758 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32759C**********************************************************************
32760C
32761C determine meson masses corresponding to the input flavours
32762C
32763C input: I,J,K quark flavours (PDG convention)
32764C
32765C output: AMPS pseudo scalar meson mass
32766C AMPS2 next possible two particle configuration
32767C (two pseudo scalar mesons)
32768C AMVE vector meson mass
32769C AMVE2 next possible two particle configuration
32770C (two vector mesons)
32771C IPS,IVE meson numbers in CPC
32772C
32773C**********************************************************************
32774 IMPLICIT NONE
32775 SAVE
32776
32777 integer I,J,IPS,IVE
32778 double precision AMPS,AMPS2,AMVE,AMVE2
32779
32780C input/output channels
32781 INTEGER LI,LO
32782 COMMON /POINOU/ LI,LO
32783C event debugging information
32784 INTEGER NMAXD
32785 PARAMETER (NMAXD=100)
32786 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32787 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32788 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32789 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32790C particle ID translation table
32791 integer ID_pdg_list,ID_list,ID_pdg_max
32792 character*12 name_list
32793 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32794 & ID_pdg_max
32795C general particle data
32796 double precision xm_list,tau_list,gam_list,
32797 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32798 & xm_bb82_list,xm_bb102_list
32799 integer ich3_list,iba3_list,iq_list,
32800 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32801 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32802 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32803 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32804 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32805 & ich3_list(300),iba3_list(300),iq_list(3,300),
32806 & id_psm_list(6,6),id_vem_list(6,6),
32807 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32808
32809C local variables
32810 integer ii,jj
32811
32812 IF(I.GT.0) THEN
32813 ii = I
32814 jj = -J
32815 ELSE
32816 ii = J
32817 jj = -I
32818 ENDIF
32819
32820C particle ID's
32821 IPS = id_psm_list(ii,jj)
32822 IVE = id_vem_list(ii,jj)
32823C masses
32824 if(IPS.ne.0) then
32825 AMPS = xm_list(iabs(IPS))
32826 else
32827 AMPS = 0.D0
32828 endif
32829 if(IVE.ne.0) then
32830 AMVE = xm_list(iabs(IVE))
32831 else
32832 AMVE = 0.D0
32833 endif
32834
32835C next possible two-particle configurations (add phase space)
32836 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32837 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32838
32839 END
32840
32841*$ CREATE PHO_BAMASS.FOR
32842*COPY PHO_BAMASS
32843CDECK ID>, PHO_BAMASS
32844 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32845C**********************************************************************
32846C
32847C determine baryon masses corresponding to the input flavours
32848C
32849C input: I,J,K quark flavours (PDG convention)
32850C
32851C output: AM8 octett baryon mass
32852C AM82 next possible two particle configuration
32853C (octett baryon and meson)
32854C AM10 decuplett baryon mass
32855C AM102 next possible two particle configuration
32856C (decuplett baryon and meson,
32857C baryon built up from first two quarks)
32858C I8,I10 internal baryon numbers
32859C
32860C**********************************************************************
32861 IMPLICIT NONE
32862 SAVE
32863
32864 integer I,J,K,I8,I10
32865 double precision AM8,AM82,AM10,AM102
32866
32867C input/output channels
32868 INTEGER LI,LO
32869 COMMON /POINOU/ LI,LO
32870C event debugging information
32871 INTEGER NMAXD
32872 PARAMETER (NMAXD=100)
32873 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32874 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32875 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32876 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32877C particle ID translation table
32878 integer ID_pdg_list,ID_list,ID_pdg_max
32879 character*12 name_list
32880 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32881 & ID_pdg_max
32882C general particle data
32883 double precision xm_list,tau_list,gam_list,
32884 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32885 & xm_bb82_list,xm_bb102_list
32886 integer ich3_list,iba3_list,iq_list,
32887 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32888 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32889 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32890 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32891 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32892 & ich3_list(300),iba3_list(300),iq_list(3,300),
32893 & id_psm_list(6,6),id_vem_list(6,6),
32894 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32895
32896C local variables
32897 integer ii,jj,kk
32898
32899C find particle ID's
32900 ii = iabs(I)
32901 jj = iabs(J)
32902 kk = iabs(K)
32903 I8 = id_b8_list(ii,jj,kk)
32904 I10 = id_b10_list(ii,jj,kk)
32905
32906C masses (if combination possible)
32907 if(I8.ne.0) then
32908 AM8 = xm_list(I8)
32909 I8 = sign(I8,i)
32910 else
32911 AM8 = 0.D0
32912 endif
32913 if(I10.ne.0) then
32914 AM10 = xm_list(I10)
32915 I10 = sign(I10,i)
32916 else
32917 AM10 = 0.D0
32918 endif
32919
32920C next possible two-particle configurations (add phase space)
32921 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32922 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32923
32924 END
32925
32926*$ CREATE PHO_DQMASS.FOR
32927*COPY PHO_DQMASS
32928CDECK ID>, PHO_DQMASS
32929 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32930C**********************************************************************
32931C
32932C determine minimal masses corresponding to the input flavours
32933C (diquark a-diquark string system)
32934C
32935C input: I,J,K,L quark flavours (PDG convention)
32936C
32937C output: AM82 mass of two octett baryons
32938C AM102 mass of two decuplett baryons
32939C
32940C**********************************************************************
32941 IMPLICIT NONE
32942 SAVE
32943
32944 integer I,J,K,L
32945 double precision AM82,AM102
32946
32947C input/output channels
32948 INTEGER LI,LO
32949 COMMON /POINOU/ LI,LO
32950C event debugging information
32951 INTEGER NMAXD
32952 PARAMETER (NMAXD=100)
32953 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32954 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32955 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32956 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32957C general particle data
32958 double precision xm_list,tau_list,gam_list,
32959 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32960 & xm_bb82_list,xm_bb102_list
32961 integer ich3_list,iba3_list,iq_list,
32962 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32963 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32964 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32965 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32966 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32967 & ich3_list(300),iba3_list(300),iq_list(3,300),
32968 & id_psm_list(6,6),id_vem_list(6,6),
32969 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32970
32971C local variables
32972 integer ii,jj,kk,ll
32973
32974 ii = iabs(i)
32975 kk = iabs(k)
32976 jj = iabs(j)
32977 ll = iabs(l)
32978
32979 AM82 = xm_bb82_list(ii,jj,kk,ll)
32980 AM102 = xm_bb102_list(ii,jj,kk,ll)
32981
32982 END
32983
32984*$ CREATE PHO_CHECK.FOR
32985*COPY PHO_CHECK
32986CDECK ID>, PHO_CHECK
32987 SUBROUTINE PHO_CHECK(MD,IDEV)
32988C**********************************************************************
32989C
32990C check quantum numbers of entries in /POEVT1/ and /POEVT2/
32991C (energy, momentum, charge, baryon number conservation)
32992C
32993C input: MD -1 check overall momentum conservation
32994C and perform detailed check only in case of
32995C deviations
32996C 1 test all branchings, mother-daughter
32997C relations
32998C
32999C output: IDEV 0 no deviations
33000C 1 deviations found
33001C
33002C**********************************************************************
33003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33004 SAVE
33005
33006C input/output channels
33007 INTEGER LI,LO
33008 COMMON /POINOU/ LI,LO
33009C event debugging information
33010 INTEGER NMAXD
33011 PARAMETER (NMAXD=100)
33012 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33013 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33014 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33015 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33016C model switches and parameters
33017 CHARACTER*8 MDLNA
33018 INTEGER ISWMDL,IPAMDL
33019 DOUBLE PRECISION PARMDL
33020 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33021C global event kinematics and particle IDs
33022 INTEGER IFPAP,IFPAB
33023 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33024 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33025C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33026 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33027 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33028 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33029 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33030C standard particle data interface
33031 INTEGER NMXHEP
33032 PARAMETER (NMXHEP=4000)
33033 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33034 DOUBLE PRECISION PHEP,VHEP
33035 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33036 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33037 & VHEP(4,NMXHEP)
33038C extension to standard particle data interface (PHOJET specific)
33039 INTEGER IMPART,IPHIST,ICOLOR
33040 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33041C color string configurations including collapsed strings and hadrons
33042 INTEGER MSTR
33043 PARAMETER (MSTR=500)
33044 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33045 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33046 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33047 & NNCH(MSTR),IBHAD(MSTR),ISTR
33048
33049C count number of errors to avoid disk overflow
33050 DATA IERR / 0 /
33051
33052 IDEV = 0
33053C conservation check suppressed
33054 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33055
33056 IF(IPAMDL(13).GT.0) THEN
33057
33058C DPMJET call with x limitations
33059 MODE = -1
33060 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33061
33062 ELSE
33063
33064C standard call
33065 MODE = MD
33066C first two entries are considered as scattering particles
33067 EE1 = PHEP(4,1) + PHEP(4,2)
33068 PX1 = PHEP(1,1) + PHEP(1,2)
33069 PY1 = PHEP(2,1) + PHEP(2,2)
33070 PZ1 = PHEP(3,1) + PHEP(3,2)
33071
33072 ENDIF
33073
33074 DDREL = PARMDL(75)
33075 DDABS = PARMDL(76)
33076 IF(MODE.EQ.-1) GOTO 500
33077
33078 50 CONTINUE
33079
33080 I = 1
33081 100 CONTINUE
33082
33083C recognize only decayed particles as mothers
33084 IF(ISTHEP(I).EQ.2) THEN
33085C search for other mother particles
33086 K = JDAHEP(1,I)
33087 IF(K.EQ.0) THEN
33088 IF(IPAMDL(178).NE.0)
33089 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33090 & 'entry marked as decayed but no dauther given:',I
33091 GOTO 99
33092 ENDIF
33093 K1 = JMOHEP(1,K)
33094 K2 = JMOHEP(2,K)
33095C sum over mother particles
33096 ICH1 = IPHO_CHR3(K1,2)
33097 IBA1 = IPHO_BAR3(K1,2)
33098 EE1 = PHEP(4,K1)
33099 PX1 = PHEP(1,K1)
33100 PY1 = PHEP(2,K1)
33101 PZ1 = PHEP(3,K1)
33102 IF(K2.LT.0) THEN
33103 K2 = -K2
33104 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33105 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33106 & 'inconsistent mother/daughter relation found',I,K1,K2
33107 CALL PHO_PREVNT(-1)
33108 ENDIF
33109 DO 400 II=K1+1,K2
33110 IF(ABS(ISTHEP(II)).LE.2) THEN
33111 ICH1 = ICH1 + IPHO_CHR3(II,2)
33112 IBA1 = IBA1 + IPHO_BAR3(II,2)
33113 EE1 = EE1 + PHEP(4,II)
33114 PX1 = PX1 + PHEP(1,II)
33115 PY1 = PY1 + PHEP(2,II)
33116 PZ1 = PZ1 + PHEP(3,II)
33117 ENDIF
33118 400 CONTINUE
33119 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33120 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33121 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33122 EE1 = EE1 + PHEP(4,K2)
33123 PX1 = PX1 + PHEP(1,K2)
33124 PY1 = PY1 + PHEP(2,K2)
33125 PZ1 = PZ1 + PHEP(3,K2)
33126 ENDIF
33127
33128C sum over daughter particles
33129 ICH2 = 0.D0
33130 IBA2 = 0.D0
33131 EE2 = 0.D0
33132 PX2 = 0.D0
33133 PY2 = 0.D0
33134 PZ2 = 0.D0
33135 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33136 IF(ABS(ISTHEP(II)).LE.2) THEN
33137 ICH2 = ICH2 + IPHO_CHR3(II,2)
33138 IBA2 = IBA2 + IPHO_BAR3(II,2)
33139 EE2 = EE2 + PHEP(4,II)
33140 PX2 = PX2 + PHEP(1,II)
33141 PY2 = PY2 + PHEP(2,II)
33142 PZ2 = PZ2 + PHEP(3,II)
33143 ENDIF
33144 200 CONTINUE
33145
33146C conservation check
33147 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33148 IF(ABS(EE1-EE2).GT.ESC) THEN
33149 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33150 & 'PHO_CHECK: energy conservation violated for',
33151 & 'entry,initial,final:',I,EE1,EE2
33152 IDEV = 1
33153 ENDIF
33154 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33155 IF(ABS(PX1-PX2).GT.ESC) THEN
33156 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33157 & 'PHO_CHECK: x-momentum conservation violated for',
33158 & 'entry,initial,final:',I,PX1,PX2
33159 IDEV = 1
33160 ENDIF
33161 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33162 IF(ABS(PY1-PY2).GT.ESC) THEN
33163 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33164 & 'PHO_CHECK: y-momentum conservation violated for',
33165 & 'entry,initial,final:',I,PY1,PY2
33166 IDEV = 1
33167 ENDIF
33168 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33169 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33170 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33171 & 'PHO_CHECK: z-momentum conservation violated for',
33172 & 'entry,initial,final:',I,PZ1,PZ2
33173 IDEV = 1
33174 ENDIF
33175 IF(ICH1.NE.ICH2) THEN
33176 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33177 & 'PHO_CHECK: charge conservation violated for',
33178 & 'entry,initial,final:',I,ICH1,ICH2
33179 IDEV = 1
33180 ENDIF
33181 IF(IBA1.NE.IBA2) THEN
33182 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33183 & 'baryon charge conservation violated for',
33184 & 'entry,initial,final:',I,IBA1,IBA2
33185 IDEV = 1
33186 ENDIF
33187 IF(IDEB(20).GE.35) THEN
33188 WRITE(LO,
33189 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33190 & 'PHO_CHECK diagnostics:',
33191 & '(1.mother/l.mother,1.daughter/l.daughter):',
33192 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33193 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33194 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33195 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33196 ENDIF
33197 ENDIF
33198 99 CONTINUE
33199 I = I+1
33200 IF(I.LE.NHEP) GOTO 100
33201
33202 55 CONTINUE
33203
33204 IERR = IERR+IDEV
33205
33206C write complete event in case of deviations
33207 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33208 CALL PHO_PREVNT(1)
33209 IF(ISTR.GT.0) THEN
33210 CALL PHO_PRSTRG
33211 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33212 ENDIF
33213 ENDIF
33214
33215C stop after too many errors
33216 IF(IERR.GT.IPAMDL(179)) THEN
33217 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33218 & 'too many inconsistencies found, program terminated',IERR
33219 CALL PHO_ABORT
33220 ENDIF
33221
33222 RETURN
33223
33224C overall check only (less time consuming)
33225
33226 500 CONTINUE
33227
33228 ICH2 = 0.D0
33229 IBA2 = 0.D0
33230 EE2 = 0.D0
33231 PX2 = 0.D0
33232 PY2 = 0.D0
33233 PZ2 = 0.D0
33234
33235 DO 300 K=3,NHEP
33236C recognize only existing particles as possible daughters
33237 IF(ABS(ISTHEP(K)).EQ.1) THEN
33238 ICH2 = ICH2 + IPHO_CHR3(K,2)
33239 IBA2 = IBA2 + IPHO_BAR3(K,2)
33240 EE2 = EE2 + PHEP(4,K)
33241 PX2 = PX2 + PHEP(1,K)
33242 PY2 = PY2 + PHEP(2,K)
33243 PZ2 = PZ2 + PHEP(3,K)
33244 ENDIF
33245 300 CONTINUE
33246
33247C check energy-momentum conservation
33248 ESC = ECM*DDREL
33249
33250 IF(IPAMDL(13).GT.0) THEN
33251
33252C DPMJET call with x limitations
33253 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33254 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33255 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256 & 'PHO_CHECK: c.m. energy conservation violated',
33257 & 'initial/final energy:',ECM1,ECM2
33258 IDEV = 1
33259 ENDIF
33260
33261 ELSE
33262
33263C standard call
33264 IF(ABS(EE1-EE2).GT.ESC) THEN
33265 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33266 & 'PHO_CHECK: energy conservation violated',
33267 & 'initial/final energy:',EE1,EE2
33268 IDEV = 1
33269 ENDIF
33270 IF(ABS(PX1-PX2).GT.ESC) THEN
33271 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33272 & 'PHO_CHECK: x-momentum conservation violated',
33273 & 'initial/final x-momentum:',PX1,PX2
33274 IDEV = 1
33275 ENDIF
33276 IF(ABS(PY1-PY2).GT.ESC) THEN
33277 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33278 & 'PHO_CHECK: y-momentum conservation violated',
33279 & 'initial/final y-momentum:',PY1,PY2
33280 IDEV = 1
33281 ENDIF
33282 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33283 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33284 & 'PHO_CHECK: z-momentum conservation violated',
33285 & 'initial/final z-momentum:',PZ1,PZ2
33286 IDEV = 1
33287 ENDIF
33288
33289C check of quantum number conservation
33290
33291 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33292 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33293
33294 IF(ICH1.NE.ICH2) THEN
33295 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33296 & 'PHO_CHECK: charge conservation violated',
33297 & 'initial/final charge sum',ICH1,ICH2
33298 IDEV = 1
33299 ENDIF
33300 IF(IBA1.NE.IBA2) THEN
33301 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33302 & 'baryonic charge conservation violated',
33303 & 'initial/final baryonic charge sum',IBA1,IBA2
33304 IDEV = 1
33305 ENDIF
33306
33307 ENDIF
33308
33309C perform detailed checks in case of deviations
33310 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33311 IF(IPAMDL(13).GT.0) THEN
33312 GOTO 55
33313 ELSE
33314 DDREL = DDREL/2.D0
33315 DDABS = DDABS/2.D0
33316 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33317 & 'increasing precision of tests to',DDREL,DDABS
33318 GOTO 50
33319 ENDIF
33320 ENDIF
33321
33322 END
33323
33324*$ CREATE PHO_ABORT.FOR
33325*COPY PHO_ABORT
33326CDECK ID>, PHO_ABORT
33327 SUBROUTINE PHO_ABORT
33328C**********************************************************************
33329C
33330C top MC event generation due to fatal error,
33331C print all information of event generation and history
33332C
33333C**********************************************************************
33334 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33335 SAVE
33336
33337C input/output channels
33338 INTEGER LI,LO
33339 COMMON /POINOU/ LI,LO
33340C event debugging information
33341 INTEGER NMAXD
33342 PARAMETER (NMAXD=100)
33343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33347C model switches and parameters
33348 CHARACTER*8 MDLNA
33349 INTEGER ISWMDL,IPAMDL
33350 DOUBLE PRECISION PARMDL
33351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33352C standard particle data interface
33353 INTEGER NMXHEP
33354 PARAMETER (NMXHEP=4000)
33355 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33356 DOUBLE PRECISION PHEP,VHEP
33357 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33358 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33359 & VHEP(4,NMXHEP)
33360C extension to standard particle data interface (PHOJET specific)
33361 INTEGER IMPART,IPHIST,ICOLOR
33362 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33363C color string configurations including collapsed strings and hadrons
33364 INTEGER MSTR
33365 PARAMETER (MSTR=500)
33366 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33367 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33368 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33369 & NNCH(MSTR),IBHAD(MSTR),ISTR
33370C light-cone x fractions and c.m. momenta of soft cut string ends
33371 INTEGER MAXSOF
33372 PARAMETER ( MAXSOF = 50 )
33373 INTEGER IJSI2,IJSI1
33374 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33375 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33376 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33377 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33378C hard scattering data
33379 INTEGER MSCAHD
33380 PARAMETER ( MSCAHD = 50 )
33381 INTEGER LSCAHD,LSC1HD,LSIDX,
33382 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33383 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33384 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33385 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33386 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33387 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33388 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33389 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33390 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33391
33392 WRITE(LO,'(//,1X,A,/,1X,A)')
33393 & 'PHO_ABORT: program execution stopped',
33394 & '===================================='
33395 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33396C
33397 CALL PHO_SETMDL(0,0,-2)
33398 CALL PHO_PREVNT(-1)
33399 CALL PHO_ACTPDF(0,-2)
33400C print selected parton flavours
33401 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33402 DO 700 I=1,KSOFT
33403 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33404 700 CONTINUE
33405 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33406 DO 750 K=1,KHARD
33407 I = LSIDX(K)
33408 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33409 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33410 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33411 750 CONTINUE
33412C print selected parton momenta
33413 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33414 DO 300 I=1,KSOFT
33415 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33416 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33417 300 CONTINUE
33418 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33419 DO 350 K=1,KHARD
33420 I = LSIDX(K)
33421 I3 = 8*I-4
33422 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33423 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33424 350 CONTINUE
33425
33426C print /POEVT1/
33427 CALL PHO_PREVNT(0)
33428
33429C fragmentation process
33430 IF(ISTR.GT.0) THEN
33431C print /POSTRG/
33432 CALL PHO_PRSTRG
33433 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33434 ENDIF
33435
33436C last message
33437 WRITE(LO,'(////5X,A,///5X,A,///)')
33438 & 'PHO_ABORT: execution terminated due to fatal error',
33439 &'*** Simulating division by zero to get traceback information ***'
33440 ISTR = 100/IPAMDL(100)
33441
33442 END
33443
33444*$ CREATE PHO_TRACE.FOR
33445*COPY PHO_TRACE
33446CDECK ID>, PHO_TRACE
33447 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33448C**********************************************************************
33449C
33450C trace program subroutines according to level,
33451C original output levels will be saved
33452C
33453C input: ISTART first event to trace
33454C ISWI number of events to trace
33455C 0 loop call, use old values
33456C -1 restore original output levels
33457C 1 store level and wait for event
33458C LEVEL desired output level
33459C 0 standard output
33460C 3 internal rejections
33461C 5 cross sections, slopes etc.
33462C 10 parameter of subroutines and
33463C results
33464C 20 huge amount of debug output
33465C 30 maximal possible output
33466C
33467C**********************************************************************
33468 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33469 SAVE
33470
33471C input/output channels
33472 INTEGER LI,LO
33473 COMMON /POINOU/ LI,LO
33474C event debugging information
33475 INTEGER NMAXD
33476 PARAMETER (NMAXD=100)
33477 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33478 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33479 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33480 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33481
33482 DIMENSION IMEM(NMAXD)
33483
33484C protect ISWI
33485 ISW = ISWI
33486 10 CONTINUE
33487 IF(ISW.EQ.0) THEN
33488 IF(KEVENT.LT.ION) THEN
33489 RETURN
33490 ELSE IF(KEVENT.EQ.ION) THEN
33491 WRITE(LO,'(///,1X,A,///)')
33492 & 'PHO_TRACE: trace mode switched on'
33493 DO 100 I=1,NMAXD
33494 IMEM(I) = IDEB(I)
33495 IDEB(I) = MAX(ILEVEL,IMEM(I))
33496 100 CONTINUE
33497 ELSE IF(KEVENT.EQ.IOFF) THEN
33498 WRITE(LO,'(//,1X,A,///)')
33499 & 'PHO_TRACE: trace mode switched off'
33500 DO 200 I=1,NMAXD
33501 IDEB(I) = IMEM(I)
33502 200 CONTINUE
33503 ENDIF
33504 ELSE IF(ISW.EQ.-1) THEN
33505 DO 300 I=1,NMAXD
33506 IDEB(I) = IMEM(I)
33507 300 CONTINUE
33508 ELSE
33509C save information
33510 ION = ISTART
33511 IOFF = ISTART+ISW
33512 ILEVEL = LEVEL
33513 ENDIF
33514C check coincidence
33515 IF(ISW.GT.0) THEN
33516 ISW=0
33517 ILEVEL = LEVEL
33518 GOTO 10
33519 ENDIF
33520
33521 END
33522
33523*$ CREATE PHO_PRSTRG.FOR
33524*COPY PHO_PRSTRG
33525CDECK ID>, PHO_PRSTRG
33526 SUBROUTINE PHO_PRSTRG
33527C**********************************************************************
33528C
33529C print information of /POSTRG/
33530C
33531C**********************************************************************
33532 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33533 SAVE
33534
33535C input/output channels
33536 INTEGER LI,LO
33537 COMMON /POINOU/ LI,LO
33538C event debugging information
33539 INTEGER NMAXD
33540 PARAMETER (NMAXD=100)
33541 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33542 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33543 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33544 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33545C standard particle data interface
33546 INTEGER NMXHEP
33547 PARAMETER (NMXHEP=4000)
33548 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33549 DOUBLE PRECISION PHEP,VHEP
33550 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33551 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33552 & VHEP(4,NMXHEP)
33553C extension to standard particle data interface (PHOJET specific)
33554 INTEGER IMPART,IPHIST,ICOLOR
33555 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33556C color string configurations including collapsed strings and hadrons
33557 INTEGER MSTR
33558 PARAMETER (MSTR=500)
33559 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33560 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33561 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33562 & NNCH(MSTR),IBHAD(MSTR),ISTR
33563
33564 WRITE(LO,'(/,1X,A,I5)')
33565 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33566 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33567 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33568 WRITE(LO,'(1X,A)')
33569 & ' ======================================================='
33570 DO 800 I=1,ISTR
33571 WRITE(LO,'(1X,9I5,1P,E11.3)')
33572 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33573 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33574 800 CONTINUE
33575
33576 END
33577
33578*$ CREATE PHO_PREVNT.FOR
33579*COPY PHO_PREVNT
33580CDECK ID>, PHO_PREVNT
33581 SUBROUTINE PHO_PREVNT(NPART)
33582C**********************************************************************
33583C
33584C print all information of event generation and history
33585C
33586C input: NPART -1 minimal output: process IDs
33587C 0 additional output of /POEVT1/
33588C 1 additional output of /POSTRG/
33589C 2 additional output of /HEPEVT/
33590C (call LULIST(1))
33591C
33592C**********************************************************************
33593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33594 SAVE
33595
33596C input/output channels
33597 INTEGER LI,LO
33598 COMMON /POINOU/ LI,LO
33599C event debugging information
33600 INTEGER NMAXD
33601 PARAMETER (NMAXD=100)
33602 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33603 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33604 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33605 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33606C model switches and parameters
33607 CHARACTER*8 MDLNA
33608 INTEGER ISWMDL,IPAMDL
33609 DOUBLE PRECISION PARMDL
33610 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33611C global event kinematics and particle IDs
33612 INTEGER IFPAP,IFPAB
33613 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33614 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33615C general process information
33616 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33617 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33618C standard particle data interface
33619 INTEGER NMXHEP
33620 PARAMETER (NMXHEP=4000)
33621 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33622 DOUBLE PRECISION PHEP,VHEP
33623 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33624 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33625 & VHEP(4,NMXHEP)
33626C extension to standard particle data interface (PHOJET specific)
33627 INTEGER IMPART,IPHIST,ICOLOR
33628 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33629C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33630 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33631 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33632 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33633 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33634
33635 CHARACTER*15 PHO_PNAME
33636
33637 IF(NPART.GE.0) WRITE(LO,'(/)')
33638 WRITE(LO,'(1X,A,1PE10.3)')
33639 & 'PHO_PREVNT: c.m. energy',ECM
33640 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33641 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33642 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33643 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33644 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33645 & KHDPO
33646 WRITE(LO,'(6X,A,I4,4I3)')
33647 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33648 & IDIFR2,IDDPOM
33649
33650 IF(IPAMDL(13).GT.0) THEN
33651 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33652 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33653 & ECMN,PCMN,SECM,SPCM
33654 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33655 ENDIF
33656
33657 IF(NPART.LT.0) RETURN
33658
33659 IF(NPART.GE.1) CALL PHO_PRSTRG
33660
33661 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33662 ICHAS = 0
33663 IBARFS = 0
33664 IMULC = 0
33665 IMUL = 0
33666 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33667 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33668 & ' IH1 IH2 CO1 CO2',
33669 & '========================================================',
33670 & '===================='
33671 DO 20 IH=1,NHEP
33672 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33673 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33674 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33675 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33676 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33677 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33678 & ICOLOR(1,IH),ICOLOR(2,IH)
33679 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33680 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33681 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33682 ENDIF
33683 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33684 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33685 IMUL = IMUL+1
33686 ENDIF
33687 20 CONTINUE
33688 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33689 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33690
33691 WRITE(LO,7)
33692 PXS = 0.D0
33693 PYS = 0.D0
33694 PZS = 0.D0
33695 P0S = 0.D0
33696 DO 30 IN=1,NHEP
33697 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33698 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33699 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33700 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33701 ELSE
33702 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33703 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33704 ENDIF
33705 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33706 PXS = PXS + PHEP(1,IN)
33707 PYS = PYS + PHEP(2,IN)
33708 PZS = PZS + PHEP(3,IN)
33709 P0S = P0S + PHEP(4,IN)
33710 ENDIF
33711 30 CONTINUE
33712 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33713 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33714 IF(P0S.LT.99999.D0) THEN
33715 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33716 ELSE
33717 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33718 ENDIF
33719 WRITE(LO,'(//)')
33720
33721 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33722 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33723 & 8H CHARGE ,8H BARYON ,/)
33724 6 FORMAT(7I8,2F8.3)
33725 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33726 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33727 & 2X,'-------------------------------',
33728 & '--------------------------------------------')
33729 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33730 9 FORMAT(I10,14X,5F10.3)
33731 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33732 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33733 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33734
33735 IF(NPART.GE.2) CALL PYLIST(1)
33736
33737 END
33738
33739*$ CREATE PHO_LTRHEP.FOR
33740*COPY PHO_LTRHEP
33741CDECK ID>, PHO_LTRHEP
33742 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33743C*******************************************************************
33744C
33745C Lorentz transformation of entries I1 to I2 in /POEVT1/
33746C
33747C********************************************************************
33748 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33749 SAVE
33750
33751 PARAMETER ( DIFF = 0.001D0,
33752 & EPS = 1.D-5 )
33753
33754C input/output channels
33755 INTEGER LI,LO
33756 COMMON /POINOU/ LI,LO
33757C event debugging information
33758 INTEGER NMAXD
33759 PARAMETER (NMAXD=100)
33760 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33761 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33762 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33763 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33764C standard particle data interface
33765 INTEGER NMXHEP
33766 PARAMETER (NMXHEP=4000)
33767 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33768 DOUBLE PRECISION PHEP,VHEP
33769 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33770 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33771 & VHEP(4,NMXHEP)
33772C extension to standard particle data interface (PHOJET specific)
33773 INTEGER IMPART,IPHIST,ICOLOR
33774 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33775
33776 DO 100 I=I1,MIN(I2,NHEP)
33777 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33778 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33779 & XX,YY,ZZ)
33780 EE=PHEP(4,I)
33781 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33782 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33783 ELSE IF(ISTHEP(I).EQ.20) THEN
33784 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33785 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33786 & XX,YY,ZZ)
33787 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33788 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33789 ENDIF
33790 100 CONTINUE
33791
33792C debug precision
33793 IF(IDEB(70).LT.1) RETURN
33794 DO 200 I=I1,MIN(NHEP,I2)
33795 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33796 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33797 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33798 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33799 WRITE(LO,'(1X,A,I5,2E13.4)')
33800 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33801 ENDIF
33802 190 CONTINUE
33803 200 CONTINUE
33804
33805 END
33806
33807*$ CREATE PHO_PECMS.FOR
33808*COPY PHO_PECMS
33809CDECK ID>, PHO_PECMS
33810 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33811C*******************************************************************
33812C
33813C calculation of cms momentum and energy of massive particle
33814C (ID= 1 using PMASS1, 2 using PMASS2)
33815C
33816C output: PP cms momentum
33817C EE energy in CMS of particle ID
33818C
33819C********************************************************************
33820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33821 SAVE
33822
33823C input/output channels
33824 INTEGER LI,LO
33825 COMMON /POINOU/ LI,LO
33826C event debugging information
33827 INTEGER NMAXD
33828 PARAMETER (NMAXD=100)
33829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33833C some constants
33834 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33835 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33836 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33837
33838 S=ECM**2
33839 PM1 = SIGN(PMASS1**2,PMASS1)
33840 PM2 = SIGN(PMASS2**2,PMASS2)
33841 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33842 & + PM1**2 + PM2**2)/(2.D0*ECM)
33843
33844 IF(ID.EQ.1) THEN
33845 EE = SQRT( PM1 + PP**2 )
33846 ELSE IF(ID.EQ.2) THEN
33847 EE = SQRT( PM2 + PP**2 )
33848 ELSE
33849 WRITE(LO,'(/1X,A,I3,/)')
33850 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33851 EE = PP
33852 ENDIF
33853
33854 END
33855
33856*$ CREATE PHO_FRAINI.FOR
33857*COPY PHO_FRAINI
33858CDECK ID>, PHO_FRAINI
33859 SUBROUTINE PHO_FRAINI(IDEFAU)
33860C***********************************************************************
33861C
33862C initialization of fragmentation packages
33863C (currently LUND JETSET)
33864C
33865C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33866C changed to work in PHOJET (R.E. 1/94)
33867C
33868C input: IDEFAU 0 no hadronization at all
33869C 1 do not touch any parameter of JETSET
33870C 2 default parameters kept, decay length 10mm to
33871C define stable particles
33872C 3 load tuned parameters for JETSET 7.3
33873C neg. value: prevent strange/charm hadrons from decaying
33874C
33875C***********************************************************************
33876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33877 SAVE
33878
33879 PARAMETER (EPS=1.D-10)
33880
33881C input/output channels
33882 INTEGER LI,LO
33883 COMMON /POINOU/ LI,LO
33884 INTEGER N,NPAD,K
33885 DOUBLE PRECISION P,V
33886 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33887 INTEGER MSTU,MSTJ
33888 DOUBLE PRECISION PARU,PARJ
33889 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33890 INTEGER KCHG
33891 DOUBLE PRECISION PMAS,PARF,VCKM
33892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33893 INTEGER MDCY,MDME,KFDP
33894 DOUBLE PRECISION BRAT
bd378884 33895 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 33896
33897 INTEGER PYCOMP
33898
33899 IDEFAB = ABS(IDEFAU)
33900
33901 IF(IDEFAB.EQ.0) THEN
33902 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33903 RETURN
33904 ENDIF
33905C defaults
33906 DEF2 = PARJ(2)
33907 IDEF12 = MSTJ(12)
33908 DEF19 = PARJ(19)
33909 DEF41 = PARJ(41)
33910 DEF42 = PARJ(42)
33911 DEF21 = PARJ(21)
33912
33913C declare stable particles
1ddc441c 33914c IF(IDEFAB.GE.2) MSTJ(22) = 2
9aaba0d6 33915
33916C load optimized parameters
33917 IF(IDEFAB.GE.3) THEN
33918* PARJ(19)=0.19
33919C Lund a-parameter
33920C (default=0.3)
33921 PARJ(41)=0.3
33922C Lund b-parameter
33923C (default=1.0)
33924 PARJ(42)=1.0
33925C Lund sigma parameter in pt distribution
33926C (default=0.36)
33927 PARJ(21)=0.36
33928 ENDIF
33929C
33930C prevent particles decaying
33931 IF(IDEFAU.LT.0) THEN
33932C K0S
33933 KC=PYCOMP(310)
33934 MDCY(KC,1)=0
33935C PI0
33936 KC=PYCOMP(111)
33937 MDCY(KC,1)=0
33938C LAMBDA
33939 KC=PYCOMP(3122)
33940 MDCY(KC,1)=0
33941C ALAMBDA
33942 KC=PYCOMP(-3122)
33943 MDCY(KC,1)=0
33944C SIG+
33945 KC=PYCOMP(3222)
33946 MDCY(KC,1)=0
33947C ASIG+
33948 KC=PYCOMP(-3222)
33949 MDCY(KC,1)=0
33950C SIG-
33951 KC=PYCOMP(3112)
33952 MDCY(KC,1)=0
33953C ASIG-
33954 KC=PYCOMP(-3112)
33955 MDCY(KC,1)=0
33956C SIG0
33957 KC=PYCOMP(3212)
33958 MDCY(KC,1)=0
33959C ASIG0
33960 KC=PYCOMP(-3212)
33961 MDCY(KC,1)=0
33962C TET0
33963 KC=PYCOMP(3322)
33964 MDCY(KC,1)=0
33965C ATET0
33966 KC=PYCOMP(-3322)
33967 MDCY(KC,1)=0
33968C TET-
33969 KC=PYCOMP(3312)
33970 MDCY(KC,1)=0
33971C ATET-
33972 KC=PYCOMP(-3312)
33973 MDCY(KC,1)=0
33974C OMEGA-
33975 KC=PYCOMP(3334)
33976 MDCY(KC,1)=0
33977C AOMEGA-
33978 KC=PYCOMP(-3334)
33979 MDCY(KC,1)=0
33980C D+
33981 KC=PYCOMP(411)
33982 MDCY(KC,1)=0
33983C D-
33984 KC=PYCOMP(-411)
33985 MDCY(KC,1)=0
33986C D0
33987 KC=PYCOMP(421)
33988 MDCY(KC,1)=0
33989C A-D0
33990 KC=PYCOMP(-421)
33991 MDCY(KC,1)=0
33992C DS+
33993 KC=PYCOMP(431)
33994 MDCY(KC,1)=0
33995C A-DS+
33996 KC=PYCOMP(-431)
33997 MDCY(KC,1)=0
33998C ETAC
33999 KC=PYCOMP(441)
34000 MDCY(KC,1)=0
34001C LAMBDAC+
34002 KC=PYCOMP(4122)
34003 MDCY(KC,1)=0
34004C A-LAMBDAC+
34005 KC=PYCOMP(-4122)
34006 MDCY(KC,1)=0
34007C SIGMAC++
34008 KC=PYCOMP(4222)
34009 MDCY(KC,1)=0
34010C SIGMAC+
34011 KC=PYCOMP(4212)
34012 MDCY(KC,1)=0
34013C SIGMAC0
34014 KC=PYCOMP(4112)
34015 MDCY(KC,1)=0
34016C A-SIGMAC++
34017 KC=PYCOMP(-4222)
34018 MDCY(KC,1)=0
34019C A-SIGMAC+
34020 KC=PYCOMP(-4212)
34021 MDCY(KC,1)=0
34022C A-SIGMAC0
34023 KC=PYCOMP(-4112)
34024 MDCY(KC,1)=0
34025C KSIC+
34026 KC=PYCOMP(4232)
34027 MDCY(KC,1)=0
34028C KSIC0
34029 KC=PYCOMP(4132)
34030 MDCY(KC,1)=0
34031C A-KSIC+
34032 KC=PYCOMP(-4232)
34033 MDCY(KC,1)=0
34034C A-KSIC0
34035 KC=PYCOMP(-4132)
34036 MDCY(KC,1)=0
34037 ENDIF
34038
34039 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34040 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34041 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34042 & ' --------------------------------------------------',/,
34043 & 5X,'parameter description default / current',/,
34044 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34045 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34046 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34047 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34048 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34049 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34050
34051 END
34052
34053*$ CREATE PHO_SETPAR.FOR
34054*COPY PHO_SETPAR
34055CDECK ID>, PHO_SETPAR
34056 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34057C**********************************************************************
34058C
34059C assign a particle to either side 1 or 2
34060C (including special treatment for remnants)
34061C
34062C input: Iside 1,2 side selected for the particle
34063C -2 output of current settings
34064C IDpdg PDG number
34065C IDcpc CPC number
34066C 0 CPC determination in subroutine
34067C -1 special particle remnant, IDPDG
34068C is the particle number the remnant
34069C corresponds to (see /POHDFL/)
34070C
34071C**********************************************************************
34072 IMPLICIT NONE
34073 SAVE
34074
34075 integer Iside,IDpdg,IDcpc
34076 double precision Pvir
34077
34078C input/output channels
34079 INTEGER LI,LO
34080 COMMON /POINOU/ LI,LO
34081C event debugging information
34082 INTEGER NMAXD
34083 PARAMETER (NMAXD=100)
34084 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34085 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34086 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34087 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34088C global event kinematics and particle IDs
34089 INTEGER IFPAP,IFPAB
34090 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34091 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34092C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34093 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34094 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34095 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34096 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34097C particle ID translation table
34098 integer ID_pdg_list,ID_list,ID_pdg_max
34099 character*12 name_list
34100 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34101 & ID_pdg_max
34102C general particle data
34103 double precision xm_list,tau_list,gam_list,
34104 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34105 & xm_bb82_list,xm_bb102_list
34106 integer ich3_list,iba3_list,iq_list,
34107 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34108 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34109 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34110 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34111 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34112 & ich3_list(300),iba3_list(300),iq_list(3,300),
34113 & id_psm_list(6,6),id_vem_list(6,6),
34114 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34115C particle decay data
34116 double precision wg_sec_list
34117 integer idec_list,isec_list
34118 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34119 & isec_list(3,500)
34120
34121C external functions
34122 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34123 double precision pho_pmass
34124
34125C local variables
34126 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34127
34128 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34129 IDcpcN = IDcpc
34130C remnant?
34131 IF(IDcpc.EQ.-1) THEN
34132 IF(Iside.EQ.1) THEN
34133 IDpdgR = 81
34134 ELSE
34135 IDpdgR = 82
34136 ENDIF
34137 IDcpcR = ipho_pdg2id(IDpdgR)
34138 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34139 IDEQP(Iside) = IDpdg
34140C copy particle properties
34141 IDB = abs(IDEQB(Iside))
34142 xm_list(IDcpcR) = xm_list(IDB)
34143 tau_list(IDcpcR) = tau_list(IDB)
34144 gam_list(IDcpcR) = gam_list(IDB)
34145 IF(IHFLS(Iside).EQ.1) THEN
34146 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34147 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34148 ELSE
34149 ich3_list(IDcpcR) = 0
34150 iba3_list(IDcpcR) = 0
34151 ENDIF
34152C quark content
34153 IFL1 = IHFLD(Iside,1)
34154 IFL2 = IHFLD(Iside,2)
34155 IFL3 = 0
34156 IF(IHFLS(Iside).EQ.1) THEN
34157 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34158 IFL1 = IHFLD(Iside,1)/1000
34159 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34160 IFL3 = IHFLD(Iside,2)
34161 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34162 IFL1 = IHFLD(Iside,1)
34163 IFL2 = IHFLD(Iside,2)/1000
34164 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34165 ENDIF
34166 ENDIF
34167 iq_list(1,IDcpcR) = IFL1
34168 iq_list(2,IDcpcR) = IFL2
34169 iq_list(3,IDcpcR) = IFL3
34170
34171 IDcpcN = IDcpcR
34172 IDPDGN = IDPDGR
34173
34174 IF(IDEB(87).GE.5) THEN
34175 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34176 & 'pho_setpar: remnant assignment side',Iside,
34177 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34178 ENDIF
34179 ELSE IF(IDcpc.EQ.0) THEN
34180C ordinary hadron
34181 IHFLS(Iside) = 1
34182 IHFLD(Iside,1) = 0
34183 IHFLD(Iside,2) = 0
34184 IDcpcN = ipho_pdg2id(IDpdg)
34185 IDpdgN = IDpdg
34186 ENDIF
34187
34188C initialize /POGCMS/
34189 IFPAP(Iside) = IDpdgN
34190 IFPAB(Iside) = IDcpcN
34191 PMASS(Iside) = pho_pmass(IDcpcN,0)
34192 IF(IFPAP(Iside).EQ.22) THEN
34193 PVIRT(Iside) = ABS(PVIR)
34194 ELSE
34195 PVIRT(Iside) = 0.D0
34196 ENDIF
34197
34198 ELSE IF(Iside.EQ.-2) THEN
34199C output of current settings
34200 DO 100 I=1,2
34201 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34202 & 'PHO_SETPAR: side',
34203 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34204 & PVIRT(I)
34205 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34206 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34207 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34208 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34209 ENDIF
34210 100 CONTINUE
34211 ELSE
34212 WRITE(LO,'(/1X,A,I8)')
34213 & 'pho_setpar: invalid argument (Iside)',Iside
34214 ENDIF
34215
34216 END
34217
34218*$ CREATE PHO_XLAM.FOR
34219*COPY PHO_XLAM
34220CDECK ID>, PHO_XLAM
34221 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34222C**********************************************************************
34223C
34224C auxiliary function for two/three particle decay mode
34225C (standard LAMBDA**(1/2) function)
34226C
34227C**********************************************************************
34228 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34229 SAVE
34230C
34231 YZ=Y-Z
34232 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34233 IF(XLAM.LT.0.D0) XLAM=-XLAM
34234 PHO_XLAM=SQRT(XLAM)
34235 END
34236
34237*$ CREATE PHO_BESSJ0.FOR
34238*COPY PHO_BESSJ0
34239CDECK ID>, PHO_BESSJ0
34240 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34241C**********************************************************************
34242C
34243C CERN (KERN) LIB function C312
34244C
34245C modified by R. Engel (03/02/93)
34246C
34247C**********************************************************************
34248 DOUBLE PRECISION DX
34249 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34250 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34251 SAVE
34252
34253 DATA EIGHT /8.0D0/
34254 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34255
34256 DATA C1( 0) /+0.15772 79714 7489D0/
34257 DATA C1( 1) /-0.00872 34423 5285D0/
34258 DATA C1( 2) /+0.26517 86132 0334D0/
34259 DATA C1( 3) /-0.37009 49938 7265D0/
34260 DATA C1( 4) /+0.15806 71023 3210D0/
34261 DATA C1( 5) /-0.03489 37694 1141D0/
34262 DATA C1( 6) /+0.00481 91800 6947D0/
34263 DATA C1( 7) /-0.00046 06261 6621D0/
34264 DATA C1( 8) /+0.00003 24603 2882D0/
34265 DATA C1( 9) /-0.00000 17619 4691D0/
34266 DATA C1(10) /+0.00000 00760 8164D0/
34267 DATA C1(11) /-0.00000 00026 7925D0/
34268 DATA C1(12) /+0.00000 00000 7849D0/
34269 DATA C1(13) /-0.00000 00000 0194D0/
34270 DATA C1(14) /+0.00000 00000 0004D0/
34271
34272 DATA C2( 0) /+0.99946 03493 4752D0/
34273 DATA C2( 1) /-0.00053 65220 4681D0/
34274 DATA C2( 2) /+0.00000 30751 8479D0/
34275 DATA C2( 3) /-0.00000 00517 0595D0/
34276 DATA C2( 4) /+0.00000 00016 3065D0/
34277 DATA C2( 5) /-0.00000 00000 7864D0/
34278 DATA C2( 6) /+0.00000 00000 0517D0/
34279 DATA C2( 7) /-0.00000 00000 0043D0/
34280 DATA C2( 8) /+0.00000 00000 0004D0/
34281 DATA C2( 9) /-0.00000 00000 0001D0/
34282
34283 DATA C3( 0) /-0.01555 58546 05337D0/
34284 DATA C3( 1) /+0.00006 83851 99426D0/
34285 DATA C3( 2) /-0.00000 07414 49841D0/
34286 DATA C3( 3) /+0.00000 00179 72457D0/
34287 DATA C3( 4) /-0.00000 00007 27192D0/
34288 DATA C3( 5) /+0.00000 00000 42201D0/
34289 DATA C3( 6) /-0.00000 00000 03207D0/
34290 DATA C3( 7) /+0.00000 00000 00301D0/
34291 DATA C3( 8) /-0.00000 00000 00033D0/
34292 DATA C3( 9) /+0.00000 00000 00004D0/
34293 DATA C3(10) /-0.00000 00000 00001D0/
34294
34295 X=DX
34296 V=ABS(X)
34297 IF(V .LT. EIGHT) THEN
34298 Y=V/EIGHT
34299 H=2.D0*Y**2-1.D0
34300 ALFA=-2.D0*H
34301 B1=0.D0
34302 B2=0.D0
34303 DO 1 I = 14,0,-1
34304 B0=C1(I)-ALFA*B1-B2
34305 B2=B1
34306 1 B1=B0
34307 B1=B0-H*B2
34308 ELSE
34309 R=1.D0/V
34310 Y=EIGHT*R
34311 H=2.D0*Y**2-1.D0
34312 ALFA=-2.D0*H
34313 B1=0.D0
34314 B2=0.D0
34315 DO 2 I = 9,0,-1
34316 B0=C2(I)-ALFA*B1-B2
34317 B2=B1
34318 2 B1=B0
34319 P=B0-H*B2
34320 B1=0.D0
34321 B2=0.D0
34322 DO 3 I = 10,0,-1
34323 B0=C3(I)-ALFA*B1-B2
34324 B2=B1
34325 3 B1=B0
34326 Q=Y*(B0-H*B2)
34327 B0=V-PI2
34328 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34329 ENDIF
34330 PHO_BESSJ0=B1
34331 RETURN
34332 END
34333
34334*$ CREATE PHO_BESSI0.FOR
34335*COPY PHO_BESSI0
34336CDECK ID>, PHO_BESSI0
34337 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34338C**********************************************************************
34339C
34340C Bessel Function I0
34341C
34342C**********************************************************************
34343 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34344 SAVE
34345
34346 AX = ABS(X)
34347 IF (AX .LT. 3.75D0) THEN
34348 Y = (X/3.75D0)**2
34349 PHO_BESSI0 =
34350 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34351 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34352 ELSE
34353 Y = 3.75D0/AX
34354 PHO_BESSI0 =
34355 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34356 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34357 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34358 & +Y*0.392377D-2))))))))
34359 ENDIF
34360
34361 END
34362
34363*$ CREATE PHO_BESSI1.FOR
34364*COPY PHO_BESSI1
34365CDECK ID>, PHO_BESSI1
34366 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34367C**********************************************************************
34368C
34369C Bessel Function I1
34370C
34371C**********************************************************************
34372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34373 SAVE
34374
34375 AX = ABS(X)
34376
34377 IF (AX .LT. 3.75D0) THEN
34378 Y = (X/3.75D0)**2
34379 BESLI1 =
34380 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34381 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34382 ELSE
34383 Y = 3.75D0/AX
34384 BESLI1 =
34385 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34386 & -Y*0.420059D-2))
34387 BESLI1 =
34388 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34389 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34390 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34391 ENDIF
34392 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34393
34394 PHO_BESSI1 = BESLI1
34395
34396 END
34397
34398*$ CREATE PHO_BESSK0.FOR
34399*COPY PHO_BESSK0
34400CDECK ID>, PHO_BESSK0
34401 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34402C**********************************************************************
34403C
34404C Modified Bessel Function K0
34405C
34406C**********************************************************************
34407 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34408 SAVE
34409
34410 IF (X .LT. 2.D0) THEN
34411 Y = X**2/4.D0
34412 PHO_BESSK0 =
34413 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34414 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34415 & +Y*(0.10750D-3+Y*0.740D-5))))))
34416 ELSE
34417 Y = 2.D0/X
34418 PHO_BESSK0 =
34419 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34420 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34421 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34422 ENDIF
34423
34424 END
34425
34426*$ CREATE PHO_BESSK1.FOR
34427*COPY PHO_BESSK1
34428CDECK ID>, PHO_BESSK1
34429 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34430C**********************************************************************
34431C
34432C Modified Bessel Function K1
34433C
34434C**********************************************************************
34435 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34436 SAVE
34437
34438 IF (X .LT. 2.D0) THEN
34439 Y = X**2/4.D0
34440 PHO_BESSK1 =
34441 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34442 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34443 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34444 ELSE
34445 Y=2.D0/X
34446 PHO_BESSK1 =
34447 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34448 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34449 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34450 ENDIF
34451
34452 END
34453
34454*$ CREATE PHO_GAUSET.FOR
34455*COPY PHO_GAUSET
34456CDECK ID>, PHO_GAUSET
34457 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34458C********************************************************************
34459C
34460C N-point gauss zeros and weights for the interval (AX,BX) are
34461C stored in arrays Z and W respectively.
34462C
34463C*********************************************************************
34464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34465 SAVE
34466
34467 COMMON /POGDAT/A(273),X(273),KTAB(96)
34468 DIMENSION Z(NX),W(NX)
34469
34470 ALPHA=0.5*(BX+AX)
34471 BETA=0.5*(BX-AX)
34472 N=NX
34473
34474C the N=1 case:
34475 IF(N.NE.1) GO TO 1
34476 Z(1)=ALPHA
34477 W(1)=BX-AX
34478 RETURN
34479
34480C the Gauss cases:
34481 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34482 IF(N.EQ.20) GO TO 2
34483 IF(N.EQ.24) GO TO 2
34484 IF(N.EQ.32) GO TO 2
34485 IF(N.EQ.40) GO TO 2
34486 IF(N.EQ.48) GO TO 2
34487 IF(N.EQ.64) GO TO 2
34488 IF(N.EQ.80) GO TO 2
34489 IF(N.EQ.96) GO TO 2
34490
34491C the extended Gauss cases:
34492 IF((N/96)*96.EQ.N) GO TO 3
34493
34494C jump to center of intervall intrgration:
34495 GO TO 100
34496
34497C get Gauss point array
34498
34499 2 CALL PHO_GAUDAT
34500C extract real points
34501 K=KTAB(N)
34502 M=N/2
34503 DO 21 J=1,M
34504C extract values from big array
34505 JTAB=K-1+J
34506 WTEMP=BETA*A(JTAB)
34507 DELTA=BETA*X(JTAB)
34508C store them backward
34509 Z(J)=ALPHA-DELTA
34510 W(J)=WTEMP
34511C store them forward
34512 JP=N+1-J
34513 Z(JP)=ALPHA+DELTA
34514 W(JP)=WTEMP
34515 21 CONTINUE
34516C store central point (odd N)
34517 IF((N-M-M).EQ.0) RETURN
34518 Z(M+1)=ALPHA
34519 JMID=K+M
34520 W(M+1)=BETA*A(JMID)
34521 RETURN
34522
34523C get ND96 times chained 96 Gauss point array
34524
34525 3 CALL PHO_GAUDAT
34526C print out message
34527C -extract real points
34528 K=KTAB(96)
34529 ND96=N/96
34530 DO 31 J=1,48
34531C extract values from big array
34532 JTAB=K-1+J
34533 WTEMP=BETA*A(JTAB)
34534 DELTA=BETA*X(JTAB)
34535 WTeMP=WTEMP/ND96
34536 DeLTA=DELTA/ND96
34537 DO 32 JD96=0,ND96-1
34538 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34539C store them backward
34540 Z(J+JD96*96)=ZCNTR-DELTA
34541 W(J+JD96*96)=WTEMP
34542C store them forward
34543 JP=96+1-J
34544 Z(JP+JD96*96)=ZCNTR+DELTA
34545 W(JP+JD96*96)=WTEMP
34546 32 CONTINUE
34547 31 CONTINUE
34548 RETURN
34549
34550C the center of intervall cases:
34551 100 CONTINUE
34552C put in constant weight and equally spaced central points
34553 N=IABS(N)
34554 DO 111 IN=1,N
34555 WIN=(BX-AX)/FLOAT(N)
34556 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34557 111 W(IN)=WIN
34558
34559 END
34560
34561*$ CREATE PHO_GAUDAT.FOR
34562*COPY PHO_GAUDAT
34563CDECK ID>, PHO_GAUDAT
34564 SUBROUTINE PHO_GAUDAT
34565C*********************************************************************
34566C
34567C store big arrays needed for Gauss integral, CERNLIB D106BD
34568C (arrays A,X,ITAB copied on B,Y,LTAB)
34569C
34570C*********************************************************************
34571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34572
34573 SAVE
34574 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34575 DIMENSION A(273),X(273),KTAB(96)
34576
34577C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34578 DATA KTAB(2)/1/
34579 DATA KTAB(3)/2/
34580 DATA KTAB(4)/4/
34581 DATA KTAB(5)/6/
34582 DATA KTAB(6)/9/
34583 DATA KTAB(7)/12/
34584 DATA KTAB(8)/16/
34585 DATA KTAB(9)/20/
34586 DATA KTAB(10)/25/
34587 DATA KTAB(11)/30/
34588 DATA KTAB(12)/36/
34589 DATA KTAB(13)/42/
34590 DATA KTAB(14)/49/
34591 DATA KTAB(15)/56/
34592 DATA KTAB(16)/64/
34593 DATA KTAB(20)/72/
34594 DATA KTAB(24)/82/
34595 DATA KTAB(28)/82/
34596 DATA KTAB(32)/94/
34597 DATA KTAB(36)/94/
34598 DATA KTAB(40)/110/
34599 DATA KTAB(44)/110/
34600 DATA KTAB(48)/130/
34601 DATA KTAB(52)/130/
34602 DATA KTAB(56)/130/
34603 DATA KTAB(60)/130/
34604 DATA KTAB(64)/154/
34605 DATA KTAB(68)/154/
34606 DATA KTAB(72)/154/
34607 DATA KTAB(76)/154/
34608 DATA KTAB(80)/186/
34609 DATA KTAB(84)/186/
34610 DATA KTAB(88)/186/
34611 DATA KTAB(92)/186/
34612 DATA KTAB(96)/226/
34613C
34614C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34615C
34616C-----N=2
34617 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34618C-----N=3
34619 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34620 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34621C-----N=4
34622 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34623 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34624C-----N=5
34625 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34626 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34627 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34628C-----N=6
34629 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34630 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34631 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34632C-----N=7
34633 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34634 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34635 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34636 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34637C-----N=8
34638 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34639 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34640 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34641 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34642C-----N=9
34643 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34644 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34645 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34646 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34647 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34648C-----N=10
34649 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34650 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34651 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34652 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34653 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34654C-----N=11
34655 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34656 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34657 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34658 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34659 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34660 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34661C-----N=12
34662 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34663 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34664 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34665 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34666 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34667 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34668C-----N=13
34669 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34670 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34671 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34672 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34673 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34674 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34675 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34676C-----N=14
34677 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34678 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34679 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34680 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34681 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34682 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34683 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34684C-----N=15
34685 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34686 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34687 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34688 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34689 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34690 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34691 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34692 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34693C-----N=16
34694 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34695 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34696 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34697 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34698 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34699 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34700 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34701 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34702C-----N=20
34703 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34704 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34705 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34706 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34707 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34708 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34709 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34710 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34711 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34712 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34713C-----N=24
34714 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34715 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34716 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34717 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34718 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34719 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34720 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34721 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34722 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34723 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34724 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34725 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34726C-----N=32
34727 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34728 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34729 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34730 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34731 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34732 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34733 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34734 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34735 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34736 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34737 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34738 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34739 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34740 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34741 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34742 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34743C-----N=40
34744 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34745 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34746 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34747 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34748 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34749 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34750 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34751 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34752 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34753 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34754 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34755 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34756 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34757 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34758 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34759 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34760 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34761 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34762 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34763 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34764C-----N=48
34765 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34766 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34767 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34768 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34769 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34770 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34771 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34772 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34773 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34774 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34775 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34776 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34777 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34778 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34779 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34780 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34781 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34782 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34783 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34784 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34785 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34786 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34787 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34788 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34789C-----N=64
34790 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34791 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34792 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34793 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34794 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34795 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34796 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34797 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34798 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34799 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34800 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34801 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34802 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34803 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34804 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34805 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34806 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34807 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34808 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34809 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34810 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34811 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34812 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34813 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34814 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34815 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34816 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34817 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34818 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34819 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34820 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34821 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34822C-----N=80
34823 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34824 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34825 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34826 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34827 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34828 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34829 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34830 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34831 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34832 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34833 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34834 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34835 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34836 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34837 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34838 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34839 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34840 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34841 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34842 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34843 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34844 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34845 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34846 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34847 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34848 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34849 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34850 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34851 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34852 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34853 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34854 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34855 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34856 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34857 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34858 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34859 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34860 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34861 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34862 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34863C-----N=96
34864 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34865 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34866 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34867 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34868 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34869 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34870 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34871 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34872 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34873 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34874 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34875 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34876 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34877 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34878 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34879 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34880 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34881 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34882 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34883 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34884 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34885 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34886 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34887 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34888 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34889 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34890 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34891 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34892 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34893 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34894 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34895 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34896 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34897 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34898 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34899 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34900 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34901 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34902 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34903 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34904 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34905 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34906 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34907 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34908 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34909 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34910 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34911 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34912 DATA IBD/0/
34913 IF(IBD.NE.0) RETURN
34914 IBD=1
34915 DO 10 I=1,273
34916 B(I) = A(I)
34917 Y(I) = X(I)
34918 10 CONTINUE
34919 DO 20 I=1,96
34920 LTAB(I) = KTAB(I)
34921 20 CONTINUE
34922 END
34923
34924*$ CREATE PHO_DZEROX.FOR
34925*COPY PHO_DZEROX
34926CDECK ID>, PHO_DZEROX
34927 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34928C**********************************************************************
34929C
34930C Based on
34931C
34932C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34933C Guaranteed Convergence for Finding a Zero of a Function,
34934C ACM Trans. Math. Software 1 (1975) 330-345.
34935C
34936C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
34937C
34938C CERNLIB C200
34939C
34940C***********************************************************************
34941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34942 SAVE
34943
34944C input/output channels
34945 INTEGER LI,LO
34946 COMMON /POINOU/ LI,LO
34947
34948 CHARACTER NAME*(*)
34949 PARAMETER (NAME = 'PHO_DZEROX')
34950 LOGICAL LMT
34951 DIMENSION IM1(2),IM2(2),LMT(2)
34952 EXTERNAL F
34953
34954 PARAMETER (Z1 = 1, HALF = Z1/2)
34955
34956 DATA IM1 /2,3/, IM2 /-1,3/
34957
34958 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34959 C=-2D+10
34960 WRITE(LO,100) NAME,MODE
34961 GO TO 99
34962 ENDIF
34963 FA=F(B0)
34964 FB=F(A0)
34965 IF(FA*FB .GT. 0) THEN
34966 C=-3D+10
34967 WRITE(LO,101) NAME
34968 GO TO 99
34969 ENDIF
34970 ATL=ABS(EPS)
34971 B=A0
34972 A=B0
34973 LMT(2)=.TRUE.
34974 MF=2
34975 1 C=A
34976 FC=FA
34977 2 IE=0
34978 3 IF(ABS(FC) .LT. ABS(FB)) THEN
34979 IF(C .NE. A) THEN
34980 D=A
34981 FD=FA
34982 END IF
34983 A=B
34984 B=C
34985 C=A
34986 FA=FB
34987 FB=FC
34988 FC=FA
34989 END IF
34990 TOL=ATL*(1+ABS(C))
34991 H=HALF*(C+B)
34992 HB=H-B
34993 IF(ABS(HB) .GT. TOL) THEN
34994 IF(IE .GT. IM1(MODE)) THEN
34995 W=HB
34996 ELSE
34997 TOL=TOL*SIGN(Z1,HB)
34998 P=(B-A)*FB
34999 LMT(1)=IE .LE. 1
35000 IF(LMT(MODE)) THEN
35001 Q=FA-FB
35002 LMT(2)=.FALSE.
35003 ELSE
35004 FDB=(FD-FB)/(D-B)
35005 FDA=(FD-FA)/(D-A)
35006 P=FDA*P
35007 Q=FDB*FA-FDA*FB
35008 END IF
35009 IF(P .LT. 0) THEN
35010 P=-P
35011 Q=-Q
35012 END IF
35013 IF(IE .EQ. IM2(MODE)) P=P+P
35014 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35015 W=TOL
35016 ELSEIF(P .LT. HB*Q) THEN
35017 W=P/Q
35018 ELSE
35019 W=HB
35020 END IF
35021 END IF
35022 D=A
35023 A=B
35024 FD=FA
35025 FA=FB
35026 B=B+W
35027 MF=MF+1
35028 IF(MF .GT. MAXF) THEN
35029 WRITE(LO,102) NAME
35030 GO TO 99
35031 ENDIF
35032 FB=F(B)
35033 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35034 IF(W .EQ. HB) GO TO 2
35035 IE=IE+1
35036 GO TO 3
35037 END IF
35038 99 CONTINUE
35039 PHO_DZEROX=C
35040 RETURN
35041 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35042 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35043 102 FORMAT(1X,A,': too many function calls')
35044
35045 END
35046
35047*$ CREATE PHO_EXPINT.FOR
35048*COPY PHO_EXPINT
35049CDECK ID>, PHO_EXPINT
35050 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35051C***********************************************************************
35052C
35053C function to calculate E_i(x) = -E_1(-x)
35054C
35055C based on CERNLIB C337 (changed by R.Engel 10/1993)
35056C
35057C***********************************************************************
35058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35059 SAVE
35060
35061C input/output channels
35062 INTEGER LI,LO
35063 COMMON /POINOU/ LI,LO
35064
35065 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35066 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35067 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35068
35069 DATA X0 /0.37250 74107 8137D0/
35070 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35071 DATA P1
35072 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35073 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35074 3 -4.34981 43832 952D+2/
35075 DATA Q1
35076 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35077 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35078 3 +7.53585 64359 843D+2/
35079 DATA P2
35080 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35081 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35082 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35083 4 +4.65627 10797 510D-7/
35084 DATA Q2
35085 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35086 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35087 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35088 4 +1.00000 00000 000D+0/
35089 DATA P3
35090 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35091 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35092 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35093 DATA Q3
35094 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35095 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35096 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35097 DATA P4
35098 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35099 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35100 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35101 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35102 DATA Q4
35103 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35104 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35105 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35106 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35107 DATA A1
35108 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35109 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35110 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35111 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35112 DATA B1
35113 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35114 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35115 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35116 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35117 DATA A2
35118 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35119 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35120 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35121 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35122 DATA B2
35123 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35124 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35125 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35126 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35127 DATA A3
35128 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35129 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35130 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35131 DATA B3
35132 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35133 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35134 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35135C
35136C conversion to E_i function
35137 X = -RXM
35138C
35139 IF(X .LE. XL(1)) THEN
35140 AP=A3(1)-X
35141 DO 1 I = 2,5
35142 1 AP=A3(I)-X+B3(I)/AP
35143 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35144 ELSEIF(X .LE. XL(2)) THEN
35145 AP=A2(1)-X
35146 DO 2 I = 2,7
35147 2 AP=A2(I)-X+B2(I)/AP
35148 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35149 ELSEIF(X .LE. XL(3)) THEN
35150 AP=A1(1)-X
35151 DO 3 I = 2,7
35152 3 AP=A1(I)-X+B1(I)/AP
35153 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35154 ELSEIF(X .LT. XL(4)) THEN
35155 V=-2.D0*(X/3.D0+1.D0)
35156 BP=0.D0
35157 DP=P4(1)
35158 DO 4 I = 2,8
35159 AP=BP
35160 BP=DP
35161 4 DP=P4(I)-AP+V*BP
35162 BQ=0.D0
35163 DQ=Q4(1)
35164 DO 14 I = 2,8
35165 AQ=BQ
35166 BQ=DQ
35167 14 DQ=Q4(I)-AQ+V*BQ
35168 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35169 ELSEIF(X .EQ. XL(4)) THEN
35170* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35171* IF(MFLAG) THEN
35172* IF(LGFILE .EQ. 0) THEN
35173* WRITE(LO,100) ENAME
35174* ELSE
35175* WRITE(LGFILE,100) ENAME
35176* ENDIF
35177* ENDIF
35178* IF(.NOT.RFLAG) CALL ABEND
35179 PHO_EXPINT=0.D0
35180 RETURN
35181 ELSEIF(X .LT. XL(5)) THEN
35182 AP=P1(1)
35183 AQ=Q1(1)
35184 DO 5 I = 2,5
35185 AP=P1(I)+X*AP
35186 5 AQ=Q1(I)+X*AQ
35187 Y=-LOG(X)+AP/AQ
35188 ELSEIF(X .LE. XL(6)) THEN
35189 Y=1.D0/X
35190 AP=P2(1)
35191 AQ=Q2(1)
35192 DO 6 I = 2,7
35193 AP=P2(I)+Y*AP
35194 6 AQ=Q2(I)+Y*AQ
35195 Y=EXP(-X)*AP/AQ
35196 ELSE
35197 Y=1.D0/X
35198 AP=P3(1)
35199 AQ=Q3(1)
35200 DO 7 I = 2,6
35201 AP=P3(I)+Y*AP
35202 7 AQ=Q3(I)+Y*AQ
35203 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35204 ENDIF
35205C sign conversion to E_i
35206 PHO_EXPINT=-Y
35207
35208 END
35209
35210*$ CREATE PHO_RNDBET.FOR
35211*COPY PHO_RNDBET
35212CDECK ID>, PHO_RNDBET
35213 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35214C********************************************************************
35215C
35216C RANDOM NUMBER GENERATION FROM BETA
35217C DISTRIBUTION IN REGION 0 < X < 1.
35218C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35219C *GAMM(ETA))
35220C
35221C********************************************************************
35222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35223 SAVE
35224
35225 Y = PHO_RNDGAM(1.D0,GAM)
35226 Z = PHO_RNDGAM(1.D0,ETA)
35227
35228 PHO_RNDBET = Y/(Y+Z)
35229
35230 END
35231
35232*$ CREATE PHO_RNDGAM.FOR
35233*COPY PHO_RNDGAM
35234CDECK ID>, PHO_RNDGAM
35235 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35236C********************************************************************
35237C
35238C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35239C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35240C
35241C********************************************************************
35242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35243 SAVE
35244C
35245 NCOU=0
35246 N = ETA
35247 F = ETA - N
35248 IF(F.EQ.0.D0) GOTO 20
35249 10 R = DT_RNDM(ETA)
35250 NCOU=NCOU+1
35251 IF (NCOU.GE.11) GOTO 20
35252 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35253 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35254 IF(ABS(YYY).GT.50.D0) GOTO 20
35255 Y = EXP(YYY)
35256 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35257 GOTO 40
35258 20 Y = 0.D0
35259 GOTO 50
35260 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35261 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35262 40 IF(N.EQ.0) GOTO 70
35263 50 Z = 1.D0
35264 DO 60 I = 1,N
35265 60 Z = Z*DT_RNDM(Y)
35266 Y = Y-LOG(Z+1.0D-9)
35267 70 PHO_RNDGAM = Y/ALAM
35268 RETURN
35269 END
35270
35271*$ CREATE PHO_SFECFE.FOR
35272*COPY PHO_SFECFE
35273CDECK ID>, PHO_SFECFE
35274 SUBROUTINE PHO_SFECFE(SFE,CFE)
35275C**********************************************************************
35276C
35277C fast random SIN(X) COS(X) selection
35278C
35279C**********************************************************************
35280 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35281 SAVE
35282C
35283 1 CONTINUE
35284 X=DT_RNDM(XX)
35285 Y=DT_RNDM(YY)
35286 XX=X*X
35287 YY=Y*Y
35288 XY=XX+YY
35289 IF(XY.GT.1.D0) GOTO 1
35290 CFE=(XX-YY)/XY
35291 SFE=2.D0*X*Y/XY
35292 IF(DT_RNDM(XY).LT.0.5D0) THEN
35293 SFE=-SFE
35294 ENDIF
35295 END
35296
35297*$ CREATE PHO_SWAPD.FOR
35298*COPY PHO_SWAPD
35299CDECK ID>, PHO_SWAPD
35300 SUBROUTINE PHO_SWAPD(D1,D2)
35301C********************************************************************
35302C
35303C exchange of argument values (double precision)
35304C
35305C********************************************************************
35306 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35307 D = D1
35308 D1 = D2
35309 D2 = D
35310 END
35311
35312*$ CREATE PHO_SWAPI.FOR
35313*COPY PHO_SWAPI
35314CDECK ID>, PHO_SWAPI
35315 SUBROUTINE PHO_SWAPI(I1,I2)
35316C********************************************************************
35317C
35318C exchange of argument values (integer)
35319C
35320C********************************************************************
35321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35322 K = I1
35323 I1 = I2
35324 I2 = K
35325 END
35326
35327*$ CREATE PHO_HADCSL.FOR
35328*COPY PHO_HADCSL
35329CDECK ID>, PHO_HADCSL
35330 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35331 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35332C***********************************************************************
35333C
35334C low-energy cross section parametrizations
35335C
35336C input: ID1,ID2 PDG IDs of particles (meson first)
35337C ECM c.m. energy (GeV)
35338C PLAB lab. momentum (second particle at rest)
35339C IMODE 1 ECM given, PLAB ignored
35340C 2 PLAB given, ECM ignored
35341C
35342C output: SIGTOT total cross section (mb)
35343C SIGEL elastic cross section (mb)
35344C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35345C SLOPE forward elastic slope (GeV**-2)
35346C RHO real/imaginary part of elastic amplitude
35347C
35348C comments:
35349C
35350C - low-energy data interpolation uses PDG fits from 1992 issue
35351C - high-energy extrapolation by Donnachie-Landshoff like fit made
35352C by PDG 1996
35353C - analytic extension of amplitude to calculate rho
35354C
35355C***********************************************************************
35356 IMPLICIT NONE
35357 SAVE
35358
35359 INTEGER ID1,ID2,IMODE
35360 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35361
35362C input/output channels
35363 INTEGER LI,LO
35364 COMMON /POINOU/ LI,LO
35365C some constants
35366 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35367 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35368 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35369C model switches and parameters
35370 CHARACTER*8 MDLNA
35371 INTEGER ISWMDL,IPAMDL
35372 DOUBLE PRECISION PARMDL
35373 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35374
35375 INTEGER K
35376 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35377 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35378
35379 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35380
35381 DATA TPDG92 /
35382 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35383 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35384 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35385 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35386 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35387 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35388 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35389 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35390 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35391 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35392 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35393 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35394
35395 DATA TPDG96 /
35396 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35397 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35398 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35399 & 77.15D0,21.05D0,0.46D0,0.9D0,
35400 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35401 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35402 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35403 & 31.85D0,4.05D0,0.45D0,0.9D0,
35404 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35405 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35406 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35407 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35408
35409 DATA BURQ83 /
35410 & 11.13D0, -6.21D0, 0.30D0,
35411 & 11.13D0, 7.23D0, 0.30D0,
35412 & 9.11D0, -0.73D0, 0.28D0,
35413 & 9.11D0, 0.65D0, 0.28D0,
35414 & 8.55D0, -5.98D0, 0.28D0,
35415 & 8.55D0, 1.60D0, 0.28D0 /
35416
35417 DATA XMA /
35418 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35419
35420C find index
35421 IF(ID2.NE.2212) THEN
35422 GOTO 100
35423 ELSE IF(ID1.EQ.2212) THEN
35424 K = 1
35425 ELSE IF(ID1.EQ.-2212) THEN
35426 K = 2
35427 ELSE IF(ID1.EQ.211) THEN
35428 K = 3
35429 ELSE IF(ID1.EQ.-211) THEN
35430 K = 4
35431 ELSE IF(ID1.EQ.321) THEN
35432 K = 5
35433 ELSE IF(ID1.EQ.-321) THEN
35434 K = 6
35435 ELSE
35436 GOTO 100
35437 ENDIF
35438
35439C calculate lab momentum
35440 IF(IMODE.EQ.1) THEN
35441 SS = ECM**2
35442 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35443 PL = SQRT(E1*E1-XMA(K)**2)
35444 ELSE IF(IMODE.EQ.2) THEN
35445 PL = PLAB
35446 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35447 ECM = SQRT(SS)
35448 ELSE
35449 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35450 RETURN
35451 ENDIF
35452 PLL = LOG(PL)
35453
35454C check against lower limit
35455 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35456
35457 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35458 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35459 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35460
35461 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35462 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35463 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35464 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35465
35466C select energy range and interpolation method
35467 IF(PL.LT.TPDG96(1,K)) THEN
35468 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35469 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35470 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35471 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35472 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35473 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35474 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35475 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35476 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35477 SIGTO2 = YP+YM+XP
35478 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35479 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35480 X1 = 1.D0 - X2
35481 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35482 SIGEL = SIGEL2*X2 + SIGEL1*X1
35483 ELSE
35484 SIGTOT = YP+YM+XP
35485 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35486 ENDIF
35487
35488C no parametrization of diffraction implemented
35489 SIGDIF(1) = -1.D0
35490 SIGDIF(2) = -1.D0
35491 SIGDIF(3) = -1.D0
35492
35493 RETURN
35494
35495 100 CONTINUE
35496 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35497 & 'invalid particle combination: ',ID1,ID2
35498 RETURN
35499
35500 200 CONTINUE
35501 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35502 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35503
35504 END
35505
35506*$ CREATE PHO_CSDIFF.FOR
35507*COPY PHO_CSDIFF
35508CDECK ID>, PHO_CSDIFF
35509 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35510 & sig_sd1,sig_sd2,sig_dd)
35511C***********************************************************************
35512C
35513C cross section for diffraction dissociation according to
35514C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35515C
35516C in addition rescaling for different particles is applied using
35517C internal rescaling tables (not implemented yet)
35518C
35519C input: Id1/2 PDG ID's of incoming particles
35520C SS squared c.m. energy (GeV**2)
35521C Xi_min min. diff mass (squared) = Xi_min*SS
35522C Xi_max max. diff mass (squared) = Xi_max*SS
35523C
35524C output: sig_sd1 cross section for diss. of particle 1 (mb)
35525C sig_sd2 cross section for diss. of particle 2 (mb)
35526C sig_dd cross section for diss. of both particles
35527C
35528C***********************************************************************
35529 IMPLICIT NONE
35530 SAVE
35531
35532 INTEGER Id1,Id2
35533 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35534
35535C input/output channels
35536 INTEGER LI,LO
35537 COMMON /POINOU/ LI,LO
35538C some constants
35539 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35540 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35541 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35542
35543 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35544 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35545 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35546 & xms_1,xms_2,CSdiff
35547
35548 INTEGER Ngau1,Ngau2,i1,i2
35549
35550C model parameters
35551
35552 DATA delta / 0.104d0 /
35553 DATA alphap / 0.25d0 /
35554 DATA beta0 / 6.56d0 /
35555 DATA gpom0 / 1.21d0 /
35556 DATA xm_p / 0.938d0 /
35557 DATA x_rad2 / 0.71d0 /
35558
35559C integration precision
35560
35561 DATA Ngau1 / 96 /
35562 DATA Ngau2 / 96 /
35563
35564 sig_sd1 = 0.d0
35565 sig_sd2 = 0.d0
35566 sig_dd = 0.d0
35567
35568 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35569
35570 xm4_p2 = 4.D0*xm_p**2
35571 fac = beta0**2/(16.D0*PI)
35572
35573 t1 = -5.D0
35574 t2 = 0.D0
35575 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35576 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35577
35578C flux renormalization and cross section
35579
35580 Xnorm = 0.d0
35581
35582 xil = log(1.5d0/SS)
35583 xiu = log(0.1d0)
35584
35585 IF(xiu.LE.xil) goto 1000
35586
35587 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35588 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35589
35590 do i1=1,Ngau1
35591
35592 xi = exp(xpos1(i1))
35593 w_xi = Xwgh1(i1)
35594
35595 do i2=1,Ngau2
35596
35597 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35598
35599 alpha_t = 1.D0+delta+alphap*tt
35600 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35601
35602 Xnorm = Xnorm
35603 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35604
35605 enddo
35606 enddo
35607
35608 Xnorm = Xnorm*fac
35609
35610 1000 continue
35611
35612 XIL = LOG(Xi_min)
35613 XIU = LOG(Xi_max)
35614
35615 T1 = -5.D0
35616 T2 = 0.D0
35617
35618 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35619 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35620
35621C single diffraction diss. cross section
35622
35623 CSdiff = 0.d0
35624
35625 IF(XIU.LE.XIL) goto 2000
35626
35627 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35628 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35629
35630 do i1=1,Ngau1
35631
35632 xi = exp(xpos1(i1))
35633 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35634
35635 do i2=1,Ngau2
35636
35637 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35638
35639 alpha_t = 1.D0+delta+alphap*tt
35640 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35641
35642 CSdiff = CSdiff
35643 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35644
35645 enddo
35646 enddo
35647
35648 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35649
35650* WRITE(LO,'(1x,1p,4e14.3)')
35651* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35652
35653 sig_sd1 = CSdiff
35654 sig_sd2 = CSdiff
35655
35656 2000 continue
35657
35658C double diffraction dissociation cross section
35659
35660 CSdiff = 0.d0
35661
35662 xil = log(1.5d0/SS)
35663 xiu = log(Xi_max/1.5d0)
35664
35665 IF(xiu.LE.xil) goto 3000
35666
35667 fac = (beta0*gpom0*SS**delta
35668 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35669 & /(2.d0*alphap)
35670
35671 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35672
35673 do i1=1,Ngau1
35674
35675 xi = exp(xpos1(i1))
35676 xms_1 = xi*SS
35677
35678 xiu = log(Xi_max/(xi*SS))
35679
35680 if(xil.lt.xiu) then
35681
35682 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35683
35684 do i2=1,Ngau2
35685
35686 xms_2 = exp(xpos2(i2))*SS
35687 CSdiff = CSdiff
35688 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35689 & *xwgh1(i1)*xwgh2(i2)
35690
35691 enddo
35692
35693 endif
35694
35695 enddo
35696
35697 sig_dd = CSdiff*fac*GEV2MB
35698
35699 3000 continue
35700
35701 ELSE
35702
35703 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35704 & 'invalid particle combination (Id1/2)',Id1,Id2
35705
35706 ENDIF
35707
35708 END
35709
35710*$ CREATE PHO_ALLM97.FOR
35711*COPY PHO_ALLM97
35712CDECK ID>, PHO_ALLM97
35713 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35714C**********************************************************************
35715C
35716C ALLM97 parametrization for gamma*-p cross section
35717C (for F2 see comments, code adapted from V. Shekelyan, H1)
35718C
35719C**********************************************************************
35720 IMPLICIT NONE
35721 SAVE
35722
35723C input/output channels
35724 INTEGER LI,LO
35725 COMMON /POINOU/ LI,LO
35726
35727 DOUBLE PRECISION Q2,W
35728 DOUBLE PRECISION M02,M12,LAM2,M22
35729 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35730 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35731 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35732 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35733 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35734
35735 W2=W*W
35736 PHO_ALLM97 = 0.D0
35737
35738C pomeron
35739 S11 = 0.28067D0
35740 S12 = 0.22291D0
35741 S13 = 2.1979D0
35742 A11 = -0.0808D0
35743 A12 = -0.44812D0
35744 A13 = 1.1709D0
35745 B11 = 0.60243D0
35746 B12 = 1.3754D0
35747 B13 = 1.8439D0
35748 M12 = 49.457D0
35749
35750C reggeon
35751 S21 = 0.80107D0
35752 S22 = 0.97307D0
35753 S23 = 3.4942D0
35754 A21 = 0.58400D0
35755 A22 = 0.37888D0
35756 A23 = 2.6063D0
35757 B21 = 0.10711D0
35758 B22 = 1.9386D0
35759 B23 = 0.49338D0
35760 M22 = 0.15052D0
35761C
35762 M02 = 0.31985D0
35763 LAM2 = 0.065270D0
35764 Q02 = 0.46017D0 +LAM2
35765
35766C
35767 S=0.
35768 T=LOG((Q2+Q02)/LAM2)
35769 T0=LOG(Q02/LAM2)
35770 IF(Q2.GT.0.D0) S=LOG(T/T0)
35771 Z=1.D0
35772
35773 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35774
35775 IF(S.LT.0.01D0) THEN
35776
35777C pomeron part
35778
35779 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35780
35781 AP=A11
35782 BP=B11**2
35783
35784 SP=S11
35785 F2P=SP*XP**AP*Z**BP
35786
35787C reggeon part
35788
35789 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35790
35791 AR=A21
35792 BR=B21**2
35793
35794 SR=S21
35795 F2R=SR*XR**AR*Z**BR
35796
35797 ELSE
35798
35799C pomeron part
35800
35801 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35802
35803 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35804
35805 BP=B11**2+B12**2*S**B13
35806
35807 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35808
35809 F2P=SP*XP**AP*Z**BP
35810
35811C reggeon part
35812
35813 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35814
35815 AR=A21+A22*S**A23
35816 BR=B21**2+B22**2*S**B23
35817
35818 SR=S21+S22*S**S23
35819 F2R=SR*XR**AR*Z**BR
35820
35821 ENDIF
35822
35823* F2 = (F2P+F2R)*Q2/(Q2+M02)
35824
35825 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35826 PHO_ALLM97 = CIN*(F2P+F2R)
35827
35828 END
35829
35830*$ CREATE PHO_DOR98LO.FOR
35831*COPY PHO_DOR98LO
35832CDECK ID>, PHO_DOR98LO
35833 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35834C***********************************************************************
35835C
35836C GRV98 parton densities, leading order set
35837C
35838C For a detailed explanation see
35839C M. Glueck, E. Reya, A. Vogt :
35840C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35841C (To appear in Eur. Phys. J. C)
35842C
35843C interpolation routine based on the original GRV98PA routine,
35844C adapted to define interpolation table as DATA statements
35845C
35846C (R.Engel, 09/98)
35847C
35848C
35849C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35850C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35851C
35852C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35853C DS = d(bar), SS = s = s(bar), GL = gluon.
35854C Always x times the distribution is returned.
35855C
35856C******************************************************i****************
35857 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35858 SAVE
35859
35860C input/output channels
35861 INTEGER LI,LO
35862 COMMON /POINOU/ LI,LO
35863
35864 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35865 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35866 1 XSF(NX,NQ), XGF(NX,NQ),
35867 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35868
35869 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35870 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35871
35872 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35873 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35874 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35875 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35876 EQUIVALENCE (XSF(1,1),XSF_L(1))
35877 EQUIVALENCE (XGF(1,1),XGF_L(1))
35878
35879 DATA (ARRF(K),K= 1, 95) /
35880 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35881 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35882 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35883 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35884 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35885 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35886 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35887 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35888 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35889 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35890 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35891 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35892 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35893 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35894 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35895 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35896 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35897 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35898 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35899 DATA (XUVF_L(K),K= 1, 114) /
35900 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35901 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35902 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35903 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35904 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35905 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35906 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35907 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35908 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35909 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35910 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35911 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35912 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35913 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35914 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35915 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35916 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35917 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35918 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35919 DATA (XUVF_L(K),K= 115, 228) /
35920 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35921 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35922 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35923 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35924 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35925 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35926 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35927 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35928 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35929 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35930 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35931 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35932 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35933 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35934 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35935 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35936 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35937 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35938 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35939 DATA (XUVF_L(K),K= 229, 342) /
35940 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35941 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35942 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35943 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35944 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35945 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35946 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35947 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35948 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35949 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35950 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35951 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35952 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35953 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35954 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35955 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35956 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35957 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35958 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35959 DATA (XUVF_L(K),K= 343, 456) /
35960 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35961 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35962 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35963 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35964 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35965 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35966 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35967 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35968 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35969 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35970 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35971 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35972 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35973 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35974 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35975 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35976 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35977 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35978 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35979 DATA (XUVF_L(K),K= 457, 570) /
35980 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35981 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35982 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35983 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35984 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35985 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35986 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35987 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35988 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35989 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35990 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35991 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35992 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35993 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35994 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35995 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35996 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35997 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35998 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35999 DATA (XUVF_L(K),K= 571, 684) /
36000 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36001 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36002 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36003 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36004 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36005 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36006 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36007 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36008 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36009 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36010 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36011 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36012 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36013 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36014 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36015 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36016 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36017 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36018 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36019 DATA (XUVF_L(K),K= 685, 798) /
36020 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36021 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36022 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36023 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36024 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36025 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36026 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36027 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36028 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36029 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36030 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36031 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36032 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36033 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36034 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36035 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36036 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36037 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36038 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36039 DATA (XUVF_L(K),K= 799, 912) /
36040 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36041 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36042 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36043 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36044 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36045 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36046 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36047 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36048 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36049 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36050 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36051 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36052 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36053 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36054 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36055 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36056 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36057 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36058 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36059 DATA (XUVF_L(K),K= 913, 1026) /
36060 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36061 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36062 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36063 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36064 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36065 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36066 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36067 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36068 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36069 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36070 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36071 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36072 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36073 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36074 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36075 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36076 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36077 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36078 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36079 DATA (XUVF_L(K),K= 1027, 1140) /
36080 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36081 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36082 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36083 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36084 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36085 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36086 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36087 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36088 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36089 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36090 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36091 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36092 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36093 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36094 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36095 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36096 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36097 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36098 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36099 DATA (XUVF_L(K),K= 1141, 1254) /
36100 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36101 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36102 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36103 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36104 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36105 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36106 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36107 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36108 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36109 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36110 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36111 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36112 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36113 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36114 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36115 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36116 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36117 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36118 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36119 DATA (XUVF_L(K),K= 1255, 1368) /
36120 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36121 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36122 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36123 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36124 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36125 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36126 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36127 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36128 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36129 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36130 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36131 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36132 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36133 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36134 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36135 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36136 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36137 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36138 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36139 DATA (XUVF_L(K),K= 1369, 1482) /
36140 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36141 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36142 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36143 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36144 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36145 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36146 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36147 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36148 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36149 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36150 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36151 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36152 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36153 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36154 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36155 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36156 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36157 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36158 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36159 DATA (XUVF_L(K),K= 1483, 1596) /
36160 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36161 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36162 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36163 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36164 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36165 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36166 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36167 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36168 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36169 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36170 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36171 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36172 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36173 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36174 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36175 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36176 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36177 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36178 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36179 DATA (XUVF_L(K),K= 1597, 1710) /
36180 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36181 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36182 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36183 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36184 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36185 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36186 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36187 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36188 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36189 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36190 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36191 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36192 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36193 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36194 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36195 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36196 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36197 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36198 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36199 DATA (XUVF_L(K),K= 1711, 1824) /
36200 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36201 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36202 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36203 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36204 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36205 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36206 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36207 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36208 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36209 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36210 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36211 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36212 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36213 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36214 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36215 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36216 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36217 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36218 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36219 DATA (XUVF_L(K),K= 1825, 1836) /
36220 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36221 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36222 DATA (XDVF_L(K),K= 1, 114) /
36223 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36224 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36225 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36226 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36227 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36228 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36229 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36230 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36231 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36232 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36233 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36234 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36235 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36236 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36237 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36238 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36239 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36240 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36241 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36242 DATA (XDVF_L(K),K= 115, 228) /
36243 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36244 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36245 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36246 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36247 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36248 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36249 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36250 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36251 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36252 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36253 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36254 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36255 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36256 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36257 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36258 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36259 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36260 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36261 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36262 DATA (XDVF_L(K),K= 229, 342) /
36263 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36264 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36265 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36266 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36267 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36268 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36269 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36270 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36271 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36272 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36273 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36274 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36275 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36276 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36277 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36278 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36279 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36280 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36281 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36282 DATA (XDVF_L(K),K= 343, 456) /
36283 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36284 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36285 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36286 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36287 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36288 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36289 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36290 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36291 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36292 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36293 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36294 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36295 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36296 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36297 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36298 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36299 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36300 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36301 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36302 DATA (XDVF_L(K),K= 457, 570) /
36303 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36304 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36305 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36306 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36307 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36308 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36309 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36310 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36311 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36312 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36313 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36314 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36315 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36316 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36317 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36318 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36319 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36320 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36321 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36322 DATA (XDVF_L(K),K= 571, 684) /
36323 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36324 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36325 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36326 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36327 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36328 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36329 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36330 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36331 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36332 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36333 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36334 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36335 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36336 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36337 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36338 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36339 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36340 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36341 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36342 DATA (XDVF_L(K),K= 685, 798) /
36343 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36344 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36345 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36346 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36347 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36348 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36349 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36350 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36351 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36352 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36353 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36354 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36355 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36356 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36357 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36358 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36359 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36360 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36361 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36362 DATA (XDVF_L(K),K= 799, 912) /
36363 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36364 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36365 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36366 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36367 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36368 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36369 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36370 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36371 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36372 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36373 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36374 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36375 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36376 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36377 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36378 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36379 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36380 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36381 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36382 DATA (XDVF_L(K),K= 913, 1026) /
36383 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36384 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36385 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36386 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36387 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36388 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36389 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36390 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36391 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36392 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36393 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36394 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36395 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36396 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36397 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36398 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36399 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36400 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36401 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36402 DATA (XDVF_L(K),K= 1027, 1140) /
36403 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36404 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36405 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36406 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36407 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36408 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36409 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36410 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36411 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36412 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36413 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36414 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36415 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36416 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36417 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36418 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36419 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36420 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36421 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36422 DATA (XDVF_L(K),K= 1141, 1254) /
36423 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36424 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36425 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36426 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36427 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36428 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36429 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36430 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36431 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36432 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36433 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36434 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36435 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36436 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36437 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36438 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36439 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36440 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36441 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36442 DATA (XDVF_L(K),K= 1255, 1368) /
36443 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36444 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36445 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36446 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36447 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36448 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36449 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36450 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36451 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36452 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36453 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36454 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36455 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36456 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36457 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36458 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36459 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36460 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36461 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36462 DATA (XDVF_L(K),K= 1369, 1482) /
36463 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36464 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36465 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36466 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36467 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36468 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36469 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36470 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36471 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36472 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36473 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36474 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36475 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36476 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36477 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36478 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36479 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36480 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36481 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36482 DATA (XDVF_L(K),K= 1483, 1596) /
36483 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36484 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36485 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36486 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36487 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36488 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36489 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36490 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36491 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36492 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36493 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36494 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36495 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36496 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36497 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36498 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36499 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36500 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36501 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36502 DATA (XDVF_L(K),K= 1597, 1710) /
36503 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36504 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36505 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36506 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36507 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36508 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36509 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36510 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36511 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36512 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36513 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36514 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36515 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36516 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36517 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36518 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36519 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36520 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36521 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36522 DATA (XDVF_L(K),K= 1711, 1824) /
36523 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36524 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36525 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36526 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36527 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36528 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36529 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36530 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36531 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36532 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36533 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36534 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36535 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36536 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36537 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36538 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36539 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36540 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36541 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36542 DATA (XDVF_L(K),K= 1825, 1836) /
36543 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36544 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36545 DATA (XDEF_L(K),K= 1, 114) /
36546 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36547 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36548 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36549 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36550 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36551 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36552 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36553 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36554 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36555 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36556 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36557 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36558 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36559 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36560 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36561 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36562 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36563 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36564 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36565 DATA (XDEF_L(K),K= 115, 228) /
36566 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36567 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36568 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36569 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36570 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36571 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36572 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36573 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36574 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36575 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36576 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36577 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36578 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36579 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36580 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36581 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36582 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36583 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36584 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36585 DATA (XDEF_L(K),K= 229, 342) /
36586 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36587 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36588 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36589 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36590 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36591 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36592 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36593 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36594 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36595 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36596 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36597 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36598 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36599 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36600 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36601 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36602 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36603 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36604 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36605 DATA (XDEF_L(K),K= 343, 456) /
36606 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36607 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36608 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36609 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36610 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36611 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36612 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36613 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36614 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36615 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36616 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36617 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36618 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36619 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36620 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36621 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36622 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36623 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36624 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36625 DATA (XDEF_L(K),K= 457, 570) /
36626 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36627 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36628 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36629 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36630 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36631 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36632 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36633 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36634 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36635 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36636 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36637 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36638 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36639 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36640 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36641 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36642 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36643 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36644 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36645 DATA (XDEF_L(K),K= 571, 684) /
36646 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36647 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36648 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36649 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36650 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36651 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36652 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36653 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36654 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36655 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36656 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36657 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36658 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36659 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36660 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36661 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36662 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36663 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36664 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36665 DATA (XDEF_L(K),K= 685, 798) /
36666 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36667 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36668 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36669 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36670 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36671 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36672 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36673 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36674 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36675 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36676 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36677 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36678 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36679 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36680 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36681 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36682 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36683 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36684 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36685 DATA (XDEF_L(K),K= 799, 912) /
36686 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36687 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36688 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36689 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36690 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36691 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36692 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36693 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36694 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36695 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36696 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36697 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36698 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36699 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36700 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36701 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36702 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36703 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36704 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36705 DATA (XDEF_L(K),K= 913, 1026) /
36706 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36707 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36708 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36709 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36710 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36711 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36712 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36713 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36714 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36715 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36716 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36717 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36718 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36719 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36720 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36721 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36722 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36723 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36724 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36725 DATA (XDEF_L(K),K= 1027, 1140) /
36726 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36727 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36728 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36729 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36730 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36731 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36732 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36733 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36734 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36735 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36736 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36737 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36738 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36739 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36740 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36741 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36742 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36743 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36744 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36745 DATA (XDEF_L(K),K= 1141, 1254) /
36746 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36747 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36748 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36749 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36750 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36751 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36752 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36753 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36754 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36755 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36756 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36757 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36758 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36759 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36760 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36761 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36762 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36763 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36764 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36765 DATA (XDEF_L(K),K= 1255, 1368) /
36766 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36767 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36768 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36769 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36770 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36771 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36772 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36773 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36774 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36775 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36776 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36777 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36778 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36779 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36780 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36781 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36782 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36783 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36784 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36785 DATA (XDEF_L(K),K= 1369, 1482) /
36786 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36787 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36788 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36789 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36790 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36791 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36792 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36793 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36794 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36795 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36796 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36797 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36798 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36799 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36800 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36801 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36802 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36803 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36804 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36805 DATA (XDEF_L(K),K= 1483, 1596) /
36806 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36807 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36808 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36809 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36810 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36811 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36812 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36813 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36814 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36815 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36816 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36817 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36818 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36819 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36820 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36821 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36822 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36823 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36824 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36825 DATA (XDEF_L(K),K= 1597, 1710) /
36826 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36827 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36828 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36829 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36830 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36831 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36832 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36833 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36834 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36835 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36836 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36837 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36838 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36839 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36840 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36841 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36842 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36843 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36844 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36845 DATA (XDEF_L(K),K= 1711, 1824) /
36846 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36847 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36848 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36849 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36850 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36851 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36852 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36853 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36854 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36855 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36856 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36857 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36858 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36859 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36860 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36861 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36862 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36863 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36864 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36865 DATA (XDEF_L(K),K= 1825, 1836) /
36866 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36867 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36868 DATA (XUDF_L(K),K= 1, 114) /
36869 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36870 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36871 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36872 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36873 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36874 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36875 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36876 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36877 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36878 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36879 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36880 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36881 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36882 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36883 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36884 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36885 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36886 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36887 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36888 DATA (XUDF_L(K),K= 115, 228) /
36889 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36890 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36891 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36892 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36893 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36894 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36895 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36896 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36897 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36898 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36899 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36900 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36901 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36902 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36903 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36904 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36905 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36906 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36907 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36908 DATA (XUDF_L(K),K= 229, 342) /
36909 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36910 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36911 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36912 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36913 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36914 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36915 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36916 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36917 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36918 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36919 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36920 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36921 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36922 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36923 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36924 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36925 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36926 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36927 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36928 DATA (XUDF_L(K),K= 343, 456) /
36929 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36930 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36931 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36932 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36933 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36934 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36935 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36936 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36937 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36938 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36939 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36940 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36941 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36942 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36943 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36944 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36945 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36946 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36947 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36948 DATA (XUDF_L(K),K= 457, 570) /
36949 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36950 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36951 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36952 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36953 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36954 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36955 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36956 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36957 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36958 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36959 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36960 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36961 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36962 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36963 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36964 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36965 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36966 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36967 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36968 DATA (XUDF_L(K),K= 571, 684) /
36969 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36970 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36971 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36972 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36973 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36974 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36975 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36976 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36977 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36978 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36979 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36980 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36981 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36982 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36983 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36984 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36985 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36986 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36987 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36988 DATA (XUDF_L(K),K= 685, 798) /
36989 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36990 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36991 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36992 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36993 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36994 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36995 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36996 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36997 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36998 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36999 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37000 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37001 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37002 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37003 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37004 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37005 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37006 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37007 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37008 DATA (XUDF_L(K),K= 799, 912) /
37009 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37010 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37011 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37012 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37013 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37014 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37015 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37016 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37017 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37018 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37019 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37020 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37021 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37022 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37023 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37024 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37025 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37026 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37027 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37028 DATA (XUDF_L(K),K= 913, 1026) /
37029 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37030 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37031 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37032 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37033 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37034 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37035 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37036 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37037 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37038 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37039 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37040 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37041 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37042 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37043 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37044 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37045 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37046 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37047 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37048 DATA (XUDF_L(K),K= 1027, 1140) /
37049 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37050 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37051 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37052 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37053 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37054 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37055 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37056 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37057 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37058 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37059 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37060 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37061 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37062 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37063 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37064 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37065 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37066 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37067 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37068 DATA (XUDF_L(K),K= 1141, 1254) /
37069 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37070 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37071 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37072 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37073 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37074 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37075 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37076 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37077 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37078 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37079 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37080 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37081 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37082 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37083 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37084 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37085 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37086 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37087 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37088 DATA (XUDF_L(K),K= 1255, 1368) /
37089 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37090 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37091 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37092 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37093 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37094 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37095 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37096 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37097 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37098 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37099 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37100 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37101 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37102 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37103 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37104 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37105 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37106 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37107 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37108 DATA (XUDF_L(K),K= 1369, 1482) /
37109 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37110 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37111 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37112 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37113 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37114 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37115 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37116 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37117 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37118 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37119 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37120 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37121 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37122 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37123 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37124 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37125 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37126 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37127 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37128 DATA (XUDF_L(K),K= 1483, 1596) /
37129 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37130 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37131 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37132 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37133 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37134 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37135 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37136 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37137 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37138 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37139 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37140 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37141 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37142 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37143 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37144 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37145 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37146 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37147 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37148 DATA (XUDF_L(K),K= 1597, 1710) /
37149 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37150 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37151 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37152 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37153 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37154 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37155 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37156 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37157 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37158 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37159 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37160 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37161 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37162 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37163 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37164 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37165 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37166 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37167 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37168 DATA (XUDF_L(K),K= 1711, 1824) /
37169 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37170 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37171 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37172 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37173 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37174 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37175 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37176 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37177 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37178 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37179 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37180 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37181 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37182 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37183 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37184 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37185 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37186 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37187 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37188 DATA (XUDF_L(K),K= 1825, 1836) /
37189 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37190 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37191 DATA (XSF_L(K),K= 1, 114) /
37192 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37193 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37194 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37195 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37196 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37197 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37198 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37199 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37200 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37201 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37202 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37203 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37204 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37205 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37206 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37207 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37208 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37209 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37210 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37211 DATA (XSF_L(K),K= 115, 228) /
37212 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37213 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37214 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37215 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37216 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37217 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37218 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37219 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37220 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37221 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37222 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37223 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37224 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37225 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37226 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37227 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37228 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37229 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37230 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37231 DATA (XSF_L(K),K= 229, 342) /
37232 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37233 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37234 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37235 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37236 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37237 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37238 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37239 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37240 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37241 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37242 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37243 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37244 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37245 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37246 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37247 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37248 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37249 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37250 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37251 DATA (XSF_L(K),K= 343, 456) /
37252 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37253 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37254 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37255 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37256 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37257 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37258 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37259 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37260 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37261 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37262 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37263 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37264 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37265 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37266 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37267 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37268 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37269 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37270 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37271 DATA (XSF_L(K),K= 457, 570) /
37272 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37273 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37274 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37275 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37276 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37277 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37278 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37279 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37280 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37281 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37282 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37283 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37284 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37285 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37286 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37287 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37288 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37289 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37290 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37291 DATA (XSF_L(K),K= 571, 684) /
37292 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37293 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37294 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37295 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37296 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37297 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37298 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37299 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37300 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37301 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37302 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37303 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37304 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37305 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37306 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37307 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37308 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37309 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37310 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37311 DATA (XSF_L(K),K= 685, 798) /
37312 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37313 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37314 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37315 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37316 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37317 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37318 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37319 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37320 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37321 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37322 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37323 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37324 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37325 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37326 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37327 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37328 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37329 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37330 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37331 DATA (XSF_L(K),K= 799, 912) /
37332 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37333 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37334 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37335 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37336 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37337 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37338 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37339 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37340 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37341 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37342 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37343 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37344 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37345 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37346 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37347 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37348 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37349 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37350 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37351 DATA (XSF_L(K),K= 913, 1026) /
37352 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37353 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37354 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37355 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37356 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37357 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37358 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37359 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37360 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37361 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37362 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37363 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37364 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37365 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37366 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37367 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37368 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37369 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37370 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37371 DATA (XSF_L(K),K= 1027, 1140) /
37372 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37373 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37374 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37375 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37376 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37377 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37378 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37379 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37380 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37381 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37382 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37383 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37384 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37385 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37386 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37387 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37388 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37389 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37390 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37391 DATA (XSF_L(K),K= 1141, 1254) /
37392 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37393 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37394 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37395 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37396 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37397 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37398 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37399 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37400 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37401 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37402 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37403 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37404 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37405 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37406 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37407 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37408 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37409 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37410 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37411 DATA (XSF_L(K),K= 1255, 1368) /
37412 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37413 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37414 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37415 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37416 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37417 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37418 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37419 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37420 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37421 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37422 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37423 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37424 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37425 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37426 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37427 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37428 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37429 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37430 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37431 DATA (XSF_L(K),K= 1369, 1482) /
37432 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37433 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37434 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37435 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37436 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37437 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37438 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37439 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37440 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37441 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37442 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37443 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37444 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37445 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37446 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37447 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37448 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37449 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37450 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37451 DATA (XSF_L(K),K= 1483, 1596) /
37452 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37453 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37454 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37455 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37456 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37457 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37458 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37459 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37460 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37461 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37462 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37463 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37464 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37465 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37466 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37467 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37468 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37469 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37470 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37471 DATA (XSF_L(K),K= 1597, 1710) /
37472 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37473 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37474 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37475 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37476 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37477 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37478 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37479 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37480 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37481 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37482 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37483 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37484 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37485 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37486 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37487 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37488 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37489 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37490 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37491 DATA (XSF_L(K),K= 1711, 1824) /
37492 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37493 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37494 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37495 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37496 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37497 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37498 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37499 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37500 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37501 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37502 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37503 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37504 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37505 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37506 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37507 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37508 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37509 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37510 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37511 DATA (XSF_L(K),K= 1825, 1836) /
37512 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37513 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37514 DATA (XGF_L(K),K= 1, 114) /
37515 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37516 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37517 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37518 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37519 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37520 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37521 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37522 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37523 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37524 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37525 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37526 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37527 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37528 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37529 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37530 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37531 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37532 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37533 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37534 DATA (XGF_L(K),K= 115, 228) /
37535 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37536 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37537 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37538 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37539 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37540 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37541 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37542 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37543 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37544 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37545 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37546 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37547 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37548 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37549 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37550 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37551 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37552 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37553 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37554 DATA (XGF_L(K),K= 229, 342) /
37555 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37556 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37557 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37558 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37559 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37560 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37561 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37562 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37563 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37564 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37565 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37566 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37567 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37568 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37569 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37570 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37571 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37572 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37573 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37574 DATA (XGF_L(K),K= 343, 456) /
37575 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37576 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37577 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37578 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37579 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37580 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37581 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37582 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37583 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37584 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37585 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37586 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37587 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37588 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37589 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37590 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37591 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37592 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37593 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37594 DATA (XGF_L(K),K= 457, 570) /
37595 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37596 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37597 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37598 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37599 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37600 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37601 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37602 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37603 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37604 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37605 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37606 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37607 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37608 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37609 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37610 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37611 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37612 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37613 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37614 DATA (XGF_L(K),K= 571, 684) /
37615 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37616 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37617 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37618 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37619 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37620 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37621 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37622 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37623 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37624 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37625 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37626 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37627 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37628 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37629 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37630 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37631 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37632 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37633 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37634 DATA (XGF_L(K),K= 685, 798) /
37635 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37636 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37637 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37638 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37639 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37640 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37641 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37642 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37643 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37644 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37645 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37646 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37647 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37648 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37649 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37650 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37651 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37652 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37653 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37654 DATA (XGF_L(K),K= 799, 912) /
37655 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37656 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37657 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37658 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37659 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37660 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37661 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37662 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37663 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37664 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37665 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37666 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37667 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37668 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37669 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37670 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37671 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37672 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37673 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37674 DATA (XGF_L(K),K= 913, 1026) /
37675 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37676 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37677 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37678 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37679 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37680 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37681 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37682 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37683 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37684 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37685 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37686 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37687 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37688 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37689 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37690 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37691 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37692 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37693 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37694 DATA (XGF_L(K),K= 1027, 1140) /
37695 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37696 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37697 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37698 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37699 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37700 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37701 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37702 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37703 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37704 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37705 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37706 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37707 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37708 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37709 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37710 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37711 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37712 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37713 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37714 DATA (XGF_L(K),K= 1141, 1254) /
37715 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37716 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37717 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37718 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37719 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37720 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37721 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37722 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37723 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37724 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37725 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37726 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37727 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37728 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37729 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37730 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37731 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37732 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37733 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37734 DATA (XGF_L(K),K= 1255, 1368) /
37735 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37736 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37737 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37738 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37739 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37740 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37741 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37742 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37743 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37744 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37745 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37746 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37747 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37748 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37749 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37750 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37751 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37752 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37753 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37754 DATA (XGF_L(K),K= 1369, 1482) /
37755 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37756 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37757 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37758 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37759 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37760 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37761 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37762 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37763 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37764 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37765 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37766 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37767 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37768 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37769 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37770 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37771 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37772 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37773 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37774 DATA (XGF_L(K),K= 1483, 1596) /
37775 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37776 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37777 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37778 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37779 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37780 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37781 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37782 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37783 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37784 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37785 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37786 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37787 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37788 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37789 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37790 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37791 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37792 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37793 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37794 DATA (XGF_L(K),K= 1597, 1710) /
37795 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37796 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37797 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37798 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37799 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37800 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37801 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37802 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37803 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37804 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37805 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37806 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37807 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37808 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37809 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37810 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37811 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37812 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37813 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37814 DATA (XGF_L(K),K= 1711, 1824) /
37815 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37816 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37817 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37818 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37819 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37820 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37821 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37822 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37823 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37824 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37825 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37826 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37827 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37828 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37829 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37830 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37831 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37832 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37833 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37834 DATA (XGF_L(K),K= 1825, 1836) /
37835 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37836 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37837
37838*
37839 X = Xinp
37840*...CHECK OF X AND Q2 VALUES :
37841 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37842* WRITE(LO,91) X
37843 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37844 X = 0.99D-9
37845* STOP
37846 ENDIF
37847
37848 Q2 = Q2inp
37849 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37850* WRITE(LO,92) Q2
37851 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37852 Q2 = 0.99E6
37853* STOP
37854 ENDIF
37855
37856*
37857*...INTERPOLATION :
37858 NA(1) = NX
37859 NA(2) = NQ
37860 XT(1) = DLOG(X)
37861 XT(2) = DLOG(Q2)
37862 X1 = 1.- X
37863 XV = X**0.5
37864 XS = X**(-0.2)
37865 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37866 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37867 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37868 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37869 US = 0.5 * (UD - DE)
37870 DS = 0.5 * (UD + DE)
37871 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37872 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37873
37874 END
37875
37876*$ CREATE PHO_DOR98SC.FOR
37877*COPY PHO_DOR98SC
37878CDECK ID>, PHO_DOR98SC
37879 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37880C***********************************************************************
37881C
37882C GRV98 parton densities, leading order set
37883C
37884C For a detailed explanation see
37885C M. Glueck, E. Reya, A. Vogt :
37886C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37887C (To appear in Eur. Phys. J. C)
37888C
37889C interpolation routine based on the original GRV98PA routine,
37890C adapted to define interpolation table as DATA statements
37891C
37892C (R.Engel, 09/98)
37893C
37894C CAUTION: this is a version with gluon shadowing corrections
37895C (R.Engel, 09/99)
37896C
37897C
37898C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37899C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37900C
37901C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37902C DS = d(bar), SS = s = s(bar), GL = gluon.
37903C Always x times the distribution is returned.
37904C
37905C******************************************************i****************
37906 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37907 SAVE
37908
37909C input/output channels
37910 INTEGER LI,LO
37911 COMMON /POINOU/ LI,LO
37912
37913 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37914 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37915 1 XSF(NX,NQ), XGF(NX,NQ),
37916 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
37917
37918 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37919 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37920
37921 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37922 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37923 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37924 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37925 EQUIVALENCE (XSF(1,1),XSF_L(1))
37926 EQUIVALENCE (XGF(1,1),XGF_L(1))
37927
37928*#################### data statements for shadowed LO PDF ##############
37929C ... deleted ...
37930*#######################################################################
37931
37932 X = Xinp
37933*...CHECK OF X AND Q2 VALUES :
37934 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37935* WRITE(LO,91) X
37936 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37937 X = 0.99D-9
37938* STOP
37939 ENDIF
37940
37941 Q2 = Q2inp
37942 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37943* WRITE(LO,92) Q2
37944 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37945 Q2 = 0.99E6
37946* STOP
37947 ENDIF
37948
37949*
37950*...INTERPOLATION :
37951 NA(1) = NX
37952 NA(2) = NQ
37953 XT(1) = DLOG(X)
37954 XT(2) = DLOG(Q2)
37955 X1 = 1.- X
37956 XV = X**0.5
37957 XS = X**(-0.2)
37958 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37959 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37960 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37961 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37962 US = 0.5 * (UD - DE)
37963 DS = 0.5 * (UD + DE)
37964 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37965 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37966
37967 END
37968
37969*$ CREATE PHO_DOR94LO.FOR
37970*COPY PHO_DOR94LO
37971CDECK ID>, PHO_DOR94LO
37972* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37973* *
37974* 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 *
37975* *
37976* 1994 UPDATE *
37977* *
37978* FOR A DETAILED EXPLANATION SEE *
37979* M. GLUECK, E.REYA, A.VOGT : *
37980* DO-TH 94/24 = DESY 94-206 *
37981* (TO APPEAR IN Z. PHYS. C) *
37982* *
37983* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
37984* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
37985* X BETWEEN 1.E-5 AND 1. *
37986* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
37987* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
37988* *
37989* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
37990* M(C) = 1.5, M(B) = 4.5 *
37991* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
37992* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
37993* LAMBDA(5) = 0.153, *
37994* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
37995* LAMBDA(5) = 0.131. *
37996* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
37997* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
37998* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
37999* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38000* GRV PARAMETRIZATION. *
38001* *
38002* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38003* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38004* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38005* *
38006* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38007*
38008*...INPUT PARAMETERS :
38009*
38010* X = MOMENTUM FRACTION
38011* Q2 = SCALE Q**2 IN GEV**2
38012*
38013*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38014*
38015* UV = U(VAL) = U - U(BAR)
38016* DV = D(VAL) = D - D(BAR)
38017* DEL = D(BAR) - U(BAR)
38018* UDB = U(BAR) + D(BAR)
38019* SB = S = S(BAR)
38020* GL = GLUON
38021*
38022*...LO PARAMETRIZATION :
38023*
38024 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38025 IMPLICIT DOUBLE PRECISION (A - Z)
38026 SAVE
38027
38028 MU2 = 0.23
38029 LAM2 = 0.2322 * 0.2322
38030 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38031 DS = SQRT (S)
38032 S2 = S * S
38033 S3 = S2 * S
38034*...UV :
38035 NU = 2.284 + 0.802 * S + 0.055 * S2
38036 AKU = 0.590 - 0.024 * S
38037 BKU = 0.131 + 0.063 * S
38038 AU = -0.449 - 0.138 * S - 0.076 * S2
38039 BU = 0.213 + 2.669 * S - 0.728 * S2
38040 CU = 8.854 - 9.135 * S + 1.979 * S2
38041 DU = 2.997 + 0.753 * S - 0.076 * S2
38042 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38043*...DV :
38044 ND = 0.371 + 0.083 * S + 0.039 * S2
38045 AKD = 0.376
38046 BKD = 0.486 + 0.062 * S
38047 AD = -0.509 + 3.310 * S - 1.248 * S2
38048 BD = 12.41 - 10.52 * S + 2.267 * S2
38049 CD = 6.373 - 6.208 * S + 1.418 * S2
38050 DD = 3.691 + 0.799 * S - 0.071 * S2
38051 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38052*...DEL :
38053 NE = 0.082 + 0.014 * S + 0.008 * S2
38054 AKE = 0.409 - 0.005 * S
38055 BKE = 0.799 + 0.071 * S
38056 AE = -38.07 + 36.13 * S - 0.656 * S2
38057 BE = 90.31 - 74.15 * S + 7.645 * S2
38058 CE = 0.0
38059 DE = 7.486 + 1.217 * S - 0.159 * S2
38060 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38061*...UDB :
38062 ALX = 1.451
38063 BEX = 0.271
38064 AKX = 0.410 - 0.232 * S
38065 BKX = 0.534 - 0.457 * S
38066 AGX = 0.890 - 0.140 * S
38067 BGX = -0.981
38068 CX = 0.320 + 0.683 * S
38069 DX = 4.752 + 1.164 * S + 0.286 * S2
38070 EX = 4.119 + 1.713 * S
38071 ESX = 0.682 + 2.978 * S
38072 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38073*...SB :
38074 ALS = 0.914
38075 BES = 0.577
38076 AKS = 1.798 - 0.596 * S
38077 AS = -5.548 + 3.669 * DS - 0.616 * S
38078 BS = 18.92 - 16.73 * DS + 5.168 * S
38079 DST = 6.379 - 0.350 * S + 0.142 * S2
38080 EST = 3.981 + 1.638 * S
38081 ESS = 6.402
38082 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38083*...GL :
38084 ALG = 0.524
38085 BEG = 1.088
38086 AKG = 1.742 - 0.930 * S
38087 BKG = - 0.399 * S2
38088 AG = 7.486 - 2.185 * S
38089 BG = 16.69 - 22.74 * S + 5.779 * S2
38090 CG = -25.59 + 29.71 * S - 7.296 * S2
38091 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38092 EG = 0.807 + 2.005 * S
38093 ESG = 3.841 + 0.316 * S
38094 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38095
38096 END
38097
38098*
38099*...NLO PARAMETRIZATION (MS(BAR)) :
38100*
38101*$ CREATE PHO_DOR94HO.FOR
38102*COPY PHO_DOR94HO
38103CDECK ID>, PHO_DOR94HO
38104 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38105 IMPLICIT DOUBLE PRECISION (A - Z)
38106 SAVE
38107
38108 MU2 = 0.34
38109 LAM2 = 0.248 * 0.248
38110 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38111 DS = SQRT (S)
38112 S2 = S * S
38113 S3 = S2 * S
38114*...UV :
38115 NU = 1.304 + 0.863 * S
38116 AKU = 0.558 - 0.020 * S
38117 BKU = 0.183 * S
38118 AU = -0.113 + 0.283 * S - 0.321 * S2
38119 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38120 CU = 7.771 - 10.09 * S + 2.630 * S2
38121 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38122 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38123*...DV :
38124 ND = 0.102 - 0.017 * S + 0.005 * S2
38125 AKD = 0.270 - 0.019 * S
38126 BKD = 0.260
38127 AD = 2.393 + 6.228 * S - 0.881 * S2
38128 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38129 CD = 17.83 - 53.47 * S + 21.24 * S2
38130 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38131 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38132*...DEL :
38133 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38134 AKE = 0.409 - 0.007 * S
38135 BKE = 0.782 + 0.082 * S
38136 AE = -29.65 + 26.49 * S + 5.429 * S2
38137 BE = 90.20 - 74.97 * S + 4.526 * S2
38138 CE = 0.0
38139 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38140 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38141*...UDB :
38142 ALX = 0.877
38143 BEX = 0.561
38144 AKX = 0.275
38145 BKX = 0.0
38146 AGX = 0.997
38147 BGX = 3.210 - 1.866 * S
38148 CX = 7.300
38149 DX = 9.010 + 0.896 * DS + 0.222 * S2
38150 EX = 3.077 + 1.446 * S
38151 ESX = 3.173 - 2.445 * DS + 2.207 * S
38152 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38153*...SB :
38154 ALS = 0.756
38155 BES = 0.216
38156 AKS = 1.690 + 0.650 * DS - 0.922 * S
38157 AS = -4.329 + 1.131 * S
38158 BS = 9.568 - 1.744 * S
38159 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38160 EST = 3.031 + 1.639 * S
38161 ESS = 5.837 + 0.815 * S
38162 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38163*...GL :
38164 ALG = 1.014
38165 BEG = 1.738
38166 AKG = 1.724 + 0.157 * S
38167 BKG = 0.800 + 1.016 * S
38168 AG = 7.517 - 2.547 * S
38169 BG = 34.09 - 52.21 * DS + 17.47 * S
38170 CG = 4.039 + 1.491 * S
38171 DG = 3.404 + 0.830 * S
38172 EG = -1.112 + 3.438 * S - 0.302 * S2
38173 ESG = 3.256 - 0.436 * S
38174 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38175
38176 END
38177
38178*$ CREATE PHO_DOR94DI.FOR
38179*COPY PHO_DOR94DI
38180CDECK ID>, PHO_DOR94DI
38181*
38182*...NLO PARAMETRIZATION (DIS) :
38183*
38184 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38185 IMPLICIT DOUBLE PRECISION (A - Z)
38186 SAVE
38187
38188 MU2 = 0.34
38189 LAM2 = 0.248 * 0.248
38190 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38191 DS = SQRT (S)
38192 S2 = S * S
38193 S3 = S2 * S
38194*...UV :
38195 NU = 2.484 + 0.116 * S + 0.093 * S2
38196 AKU = 0.563 - 0.025 * S
38197 BKU = 0.054 + 0.154 * S
38198 AU = -0.326 - 0.058 * S - 0.135 * S2
38199 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38200 CU = 11.52 - 12.99 * S + 3.161 * S2
38201 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38202 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38203*...DV :
38204 ND = 0.156 - 0.017 * S
38205 AKD = 0.299 - 0.022 * S
38206 BKD = 0.259 - 0.015 * S
38207 AD = 3.445 + 1.278 * S + 0.326 * S2
38208 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38209 CD = 55.45 - 69.92 * S + 20.78 * S2
38210 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38211 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38212*...DEL :
38213 NE = 0.099 + 0.019 * S + 0.002 * S2
38214 AKE = 0.419 - 0.013 * S
38215 BKE = 1.064 - 0.038 * S
38216 AE = -44.00 + 98.70 * S - 14.79 * S2
38217 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38218 CE = 84.57 - 108.8 * S + 31.52 * S2
38219 DE = 7.469 + 2.480 * S - 0.866 * S2
38220 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38221*...UDB :
38222 ALX = 1.215
38223 BEX = 0.466
38224 AKX = 0.326 + 0.150 * S
38225 BKX = 0.956 + 0.405 * S
38226 AGX = 0.272
38227 BGX = 3.794 - 2.359 * DS
38228 CX = 2.014
38229 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38230 EX = 3.049 + 1.597 * S
38231 ESX = 4.396 - 4.594 * DS + 3.268 * S
38232 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38233*...SB :
38234 ALS = 0.175
38235 BES = 0.344
38236 AKS = 1.415 - 0.641 * DS
38237 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38238 BS = 5.617 + 5.709 * DS - 3.972 * S
38239 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38240 EST = 4.546 + 0.372 * S2
38241 ESS = 5.053 - 1.070 * S + 0.805 * S2
38242 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38243*...GL :
38244 ALG = 1.258
38245 BEG = 1.846
38246 AKG = 2.423
38247 BKG = 2.427 + 1.311 * S - 0.153 * S2
38248 AG = 25.09 - 7.935 * S
38249 BG = -14.84 - 124.3 * DS + 72.18 * S
38250 CG = 590.3 - 173.8 * S
38251 DG = 5.196 + 1.857 * S
38252 EG = -1.648 + 3.988 * S - 0.432 * S2
38253 ESG = 3.232 - 0.542 * S
38254 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38255
38256 END
38257
38258*
38259*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38260*
38261*$ CREATE PHO_DOR94FV.FOR
38262*COPY PHO_DOR94FV
38263CDECK ID>, PHO_DOR94FV
38264 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38265 IMPLICIT DOUBLE PRECISION (A - Z)
38266 SAVE
38267
38268 DX = SQRT (X)
38269 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38270
38271 END
38272
38273*$ CREATE PHO_DOR94FW.FOR
38274*COPY PHO_DOR94FW
38275CDECK ID>, PHO_DOR94FW
38276 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38277 & A,B,C,D,E,ES)
38278 IMPLICIT DOUBLE PRECISION (A - Z)
38279 SAVE
38280
38281 LX = LOG (1./X)
38282 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38283 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38284
38285 END
38286
38287*$ CREATE PHO_DOR94FS.FOR
38288*COPY PHO_DOR94FS
38289CDECK ID>, PHO_DOR94FS
38290 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38291 IMPLICIT DOUBLE PRECISION (A - Z)
38292 SAVE
38293
38294 DX = SQRT (X)
38295 LX = LOG (1./X)
38296 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38297 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38298
38299 END
38300
38301*$ CREATE PHO_DOR92LO.FOR
38302*COPY PHO_DOR92LO
38303CDECK ID>, PHO_DOR92LO
38304*
38305*
38306* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38307* *
38308* 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 *
38309* *
38310* FOR A DETAILED EXPLANATION SEE : *
38311* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38312* *
38313* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38314* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38315* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38316* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38317* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38318* *
38319* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38320* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38321* *
38322* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38323* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38324* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38325* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38326* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38327* *
38328* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38329* *
38330* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38331C
38332 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38333 IMPLICIT DOUBLE PRECISION (A - Z)
38334 SAVE
38335
38336 MU2 = 0.25
38337 LAM2 = 0.232 * 0.232
38338 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38339 S2 = S * S
38340 S3 = S2 * S
38341C...X * (UV + DV) :
38342 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38343 AKUD = 0.326
38344 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38345 BUD = 24.4 - 20.7 * S + 4.08 * S2
38346 DUD = 2.86 + 0.70 * S - 0.02 * S2
38347 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38348C...X * DV :
38349 ND = 0.579 + 0.283 * S + 0.047 * S2
38350 AKD = 0.523 - 0.015 * S
38351 AGD = 2.22 - 0.59 * S - 0.27 * S2
38352 BD = 5.95 - 6.19 * S + 1.55 * S2
38353 DD = 3.57 + 0.94 * S - 0.16 * S2
38354 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38355C...X * G :
38356 ALG = 0.558
38357 BEG = 1.218
38358 AKG = 1.00 - 0.17 * S
38359 BKG = 0.0
38360 AGG = 0.0 + 4.879 * S - 1.383 * S2
38361 BGG = 25.92 - 28.97 * S + 5.596 * S2
38362 CG = -25.69 + 23.68 * S - 1.975 * S2
38363 DG = 2.537 + 1.718 * S + 0.353 * S2
38364 EG = 0.595 + 2.138 * S
38365 ESG = 4.066
38366 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38367C...X * UBAR = X * DBAR :
38368 ALU = 1.396
38369 BEU = 1.331
38370 AKU = 0.412 - 0.171 * S
38371 BKU = 0.566 - 0.496 * S
38372 AGU = 0.363
38373 BGU = -1.196
38374 CU = 1.029 + 1.785 * S - 0.459 * S2
38375 DU = 4.696 + 2.109 * S
38376 EU = 3.838 + 1.944 * S
38377 ESU = 2.845
38378 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38379C...X * SBAR = X * S :
38380 SS = 0.0
38381 ALS = 0.803
38382 BES = 0.563
38383 AKS = 2.082 - 0.577 * S
38384 AGS = -3.055 + 1.024 * S ** 0.67
38385 BS = 27.4 - 20.0 * S ** 0.154
38386 DS = 6.22
38387 EST = 4.33 + 1.408 * S
38388 ESS = 8.27 - 0.437 * S
38389 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38390C...X * CBAR = X * C :
38391 SC = 0.888
38392 ALC = 1.01
38393 BEC = 0.37
38394 AKC = 0.0
38395 AGC = 0.0
38396 BC = 4.24 - 0.804 * S
38397 DC = 3.46 + 1.076 * S
38398 EC = 4.61 + 1.490 * S
38399 ESC = 2.555 + 1.961 * S
38400 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38401C...X * BBAR = X * B :
38402 SBO = 1.351
38403 ALB = 1.00
38404 BEB = 0.51
38405 AKB = 0.0
38406 AGB = 0.0
38407 BBO = 1.848
38408 DB = 2.929 + 1.396 * S
38409 EB = 4.71 + 1.514 * S
38410 ESB = 4.02 + 1.239 * S
38411 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38412
38413 END
38414
38415*$ CREATE PHO_DOR92HO.FOR
38416*COPY PHO_DOR92HO
38417CDECK ID>, PHO_DOR92HO
38418 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38419 IMPLICIT DOUBLE PRECISION (A - Z)
38420 SAVE
38421
38422 MU2 = 0.3
38423 LAM2 = 0.248 * 0.248
38424 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38425 DS = SQRT (S)
38426 S2 = S * S
38427 S3 = S2 * S
38428C...X * (UV + DV) :
38429 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38430 AKUD = 0.285
38431 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38432 BUD = 56.7 - 53.6 * S + 11.21 * S2
38433 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38434 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38435C...X * DV :
38436 ND = 0.459 + 0.315 * DS + 0.515 * S
38437 AKD = 0.624 - 0.031 * S
38438 AGD = 8.13 - 6.77 * DS + 0.46 * S
38439 BD = 6.59 - 12.83 * DS + 5.65 * S
38440 DD = 3.98 + 1.04 * S - 0.34 * S2
38441 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38442C...X * G :
38443 ALG = 1.128
38444 BEG = 1.575
38445 AKG = 0.323 + 1.653 * S
38446 BKG = 0.811 + 2.044 * S
38447 AGG = 0.0 + 1.963 * S - 0.519 * S2
38448 BGG = 0.078 + 6.24 * S
38449 CG = 30.77 - 24.19 * S
38450 DG = 3.188 + 0.720 * S
38451 EG = -0.881 + 2.687 * S
38452 ESG = 2.466
38453 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38454C...X * UBAR = X * DBAR :
38455 ALU = 0.594
38456 BEU = 0.614
38457 AKU = 0.636 - 0.084 * S
38458 BKU = 0.0
38459 AGU = 1.121 - 0.193 * S
38460 BGU = 0.751 - 0.785 * S
38461 CU = 8.57 - 1.763 * S
38462 DU = 10.22 + 0.668 * S
38463 EU = 3.784 + 1.280 * S
38464 ESU = 1.808 + 0.980 * S
38465 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38466C...X * SBAR = X * S :
38467 SS = 0.0
38468 ALS = 0.756
38469 BES = 0.101
38470 AKS = 2.942 - 1.016 * S
38471 AGS = -4.60 + 1.167 * S
38472 BS = 9.31 - 1.324 * S
38473 DS = 11.49 - 1.198 * S + 0.053 * S2
38474 EST = 2.630 + 1.729 * S
38475 ESS = 8.12
38476 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38477C...X * CBAR = X * C :
38478 SC = 0.820
38479 ALC = 0.98
38480 BEC = 0.0
38481 AKC = -0.625 - 0.523 * S
38482 AGC = 0.0
38483 BC = 1.896 + 1.616 * S
38484 DC = 4.12 + 0.683 * S
38485 EC = 4.36 + 1.328 * S
38486 ESC = 0.677 + 0.679 * S
38487 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38488C...X * BBAR = X * B :
38489 SBO = 1.297
38490 ALB = 0.99
38491 BEB = 0.0
38492 AKB = 0.0 - 0.193 * S
38493 AGB = 0.0
38494 BBO = 0.0
38495 DB = 3.447 + 0.927 * S
38496 EB = 4.68 + 1.259 * S
38497 ESB = 1.892 + 2.199 * S
38498 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38499
38500 END
38501
38502*$ CREATE PHO_DOR92FV.FOR
38503*COPY PHO_DOR92FV
38504CDECK ID>, PHO_DOR92FV
38505 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38506 IMPLICIT DOUBLE PRECISION (A - Z)
38507 SAVE
38508 DX = SQRT (X)
38509 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38510
38511 END
38512
38513*$ CREATE PHO_DOR92FW.FOR
38514*COPY PHO_DOR92FW
38515CDECK ID>, PHO_DOR92FW
38516 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38517 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38518 IMPLICIT DOUBLE PRECISION (A - Z)
38519 SAVE
38520 LX = LOG (1./X)
38521 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38522 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38523
38524 END
38525
38526*$ CREATE PHO_DOR92FS.FOR
38527*COPY PHO_DOR92FS
38528CDECK ID>, PHO_DOR92FS
38529 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38530 IMPLICIT DOUBLE PRECISION (A - Z)
38531 SAVE
38532
38533 DX = SQRT (X)
38534 LX = LOG (1./X)
38535 IF (S .LE. ST) THEN
38536 PHO_DOR92FS = 0.D0
38537 ELSE
38538 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38539 1 * EXP (-E + SQRT (ES * S**BE * LX))
38540 END IF
38541
38542 END
38543
38544*$ CREATE PHO_DORPLO.FOR
38545*COPY PHO_DORPLO
38546CDECK ID>, PHO_DORPLO
38547*
38548* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38549* *
38550* G R V - P I O N - P A R A M E T R I Z A T I O N S *
38551* *
38552* FOR A DETAILED EXPLANATION SEE : *
38553* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38554* *
38555* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38556* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38557* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38558* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38559* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38560* *
38561* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38562* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38563* *
38564* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38565* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38566* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38567* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38568* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38569* *
38570* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38571* *
38572* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38573C
38574 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38575 IMPLICIT DOUBLE PRECISION (A - Z)
38576 SAVE
38577
38578 MU2 = 0.25
38579 LAM2 = 0.232 * 0.232
38580 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38581 DS = SQRT (S)
38582 S2 = S * S
38583C...X * VALENCE :
38584 NV = 0.519 + 0.180 * S - 0.011 * S2
38585 AKV = 0.499 - 0.027 * S
38586 AGV = 0.381 - 0.419 * S
38587 DV = 0.367 + 0.563 * S
38588 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38589C...X * GLUON :
38590 ALG = 0.599
38591 BEG = 1.263
38592 AKG = 0.482 + 0.341 * DS
38593 BKG = 0.0
38594 AGG = 0.678 + 0.877 * S - 0.175 * S2
38595 BGG = 0.338 - 1.597 * S
38596 CG = 0.0 - 0.233 * S + 0.406 * S2
38597 DG = 0.390 + 1.053 * S
38598 EG = 0.618 + 2.070 * S
38599 ESG = 3.676
38600 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38601C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38602 SL = 0.0
38603 ALS = 0.55
38604 BES = 0.56
38605 AKS = 2.538 - 0.763 * S
38606 AGS = -0.748
38607 BS = 0.313 + 0.935 * S
38608 DS = 3.359
38609 EST = 4.433 + 1.301 * S
38610 ESS = 9.30 - 0.887 * S
38611 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38612C...X * CBAR = X * C :
38613 SC = 0.888
38614 ALC = 1.02
38615 BEC = 0.39
38616 AKC = 0.0
38617 AGC = 0.0
38618 BC = 1.008
38619 DC = 1.208 + 0.771 * S
38620 EC = 4.40 + 1.493 * S
38621 ESC = 2.032 + 1.901 * S
38622 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38623C...X * BBAR = X * B :
38624 SBO = 1.351
38625 ALB = 1.03
38626 BEB = 0.39
38627 AKB = 0.0
38628 AGB = 0.0
38629 BBO = 0.0
38630 DB = 0.697 + 0.855 * S
38631 EB = 4.51 + 1.490 * S
38632 ESB = 3.056 + 1.694 * S
38633 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38634
38635 END
38636
38637*$ CREATE PHO_DORPHO.FOR
38638*COPY PHO_DORPHO
38639CDECK ID>, PHO_DORPHO
38640 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38641 IMPLICIT DOUBLE PRECISION (A - Z)
38642 SAVE
38643
38644 MU2 = 0.3
38645 LAM2 = 0.248 * 0.248
38646 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38647 DS = SQRT (S)
38648 S2 = S * S
38649C...X * VALENCE :
38650 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38651 AKV = 0.505 - 0.033 * S
38652 AGV = 0.748 - 0.669 * DS - 0.133 * S
38653 DV = 0.365 + 0.197 * DS + 0.394 * S
38654 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38655C...X * GLUON :
38656 ALG = 1.096
38657 BEG = 1.371
38658 AKG = 0.437 - 0.689 * DS
38659 BKG = -0.631
38660 AGG = 1.324 - 0.441 * DS - 0.130 * S
38661 BGG = -0.955 + 0.259 * S
38662 CG = 1.075 - 0.302 * S
38663 DG = 1.158 + 1.229 * S
38664 EG = 0.0 + 2.510 * S
38665 ESG = 2.604 + 0.165 * S
38666 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38667C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38668 SL = 0.0
38669 ALS = 0.85
38670 BES = 0.96
38671 AKS = -0.350 + 0.806 * S
38672 AGS = -1.663
38673 BS = 3.148
38674 DS = 2.273 + 1.438 * S
38675 EST = 3.214 + 1.545 * S
38676 ESS = 1.341 + 1.938 * S
38677 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38678C...X * CBAR = X * C :
38679 SC = 0.820
38680 ALC = 0.98
38681 BEC = 0.0
38682 AKC = 0.0 - 0.457 * S
38683 AGC = 0.0
38684 BC = -1.00 + 1.40 * S
38685 DC = 1.318 + 0.584 * S
38686 EC = 4.45 + 1.235 * S
38687 ESC = 1.496 + 1.010 * S
38688 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38689C...X * BBAR = X * B :
38690 SBO = 1.297
38691 ALB = 0.99
38692 BEB = 0.0
38693 AKB = 0.0 - 0.172 * S
38694 AGB = 0.0
38695 BBO = 0.0
38696 DB = 1.447 + 0.485 * S
38697 EB = 4.79 + 1.164 * S
38698 ESB = 1.724 + 2.121 * S
38699 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38700
38701 END
38702
38703*$ CREATE PHO_DORFVP.FOR
38704*COPY PHO_DORFVP
38705CDECK ID>, PHO_DORFVP
38706 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38707 IMPLICIT DOUBLE PRECISION (A - Z)
38708 SAVE
38709
38710 DX = SQRT (X)
38711 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38712
38713 END
38714
38715*$ CREATE PHO_DORFGP.FOR
38716*COPY PHO_DORFGP
38717CDECK ID>, PHO_DORFGP
38718 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38719 & BG,C,D,E,ES)
38720 IMPLICIT DOUBLE PRECISION (A - Z)
38721 SAVE
38722
38723 DX = SQRT (X)
38724 LX = LOG (1./X)
38725 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38726 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38727
38728 END
38729
38730*$ CREATE PHO_DORFQP.FOR
38731*COPY PHO_DORFQP
38732CDECK ID>, PHO_DORFQP
38733 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38734 IMPLICIT DOUBLE PRECISION (A - Z)
38735 SAVE
38736
38737 DX = SQRT (X)
38738 LX = LOG (1./X)
38739 IF (S .LE. ST) THEN
38740 PHO_DORFQP = 0.0
38741 ELSE
38742 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38743 1 * EXP (-E + SQRT (ES * S**BE * LX))
38744 END IF
38745
38746 END
38747
38748*$ CREATE PHO_DORGLO.FOR
38749*COPY PHO_DORGLO
38750CDECK ID>, PHO_DORGLO
38751* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38752* *
38753* 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 *
38754* *
38755* FOR A DETAILED EXPLANATION SEE : *
38756* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38757* *
38758* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38759* *
38760* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38761* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38762* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38763* *
38764* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38765* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38766* *
38767* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38768* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38769* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38770* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38771* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38772* *
38773* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38774* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38775* *
38776* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38777C
38778 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38779 IMPLICIT DOUBLE PRECISION (A - Z)
38780 SAVE
38781
38782 MU2 = 0.25
38783 LAM2 = 0.232 * 0.232
38784 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38785 SS = SQRT (S)
38786 S2 = S * S
38787C...X * U = X * UBAR :
38788 AL = 1.717
38789 BE = 0.641
38790 AK = 0.500 - 0.176 * S
38791 BK = 15.00 - 5.687 * SS - 0.552 * S2
38792 AG = 0.235 + 0.046 * SS
38793 BG = 0.082 - 0.051 * S + 0.168 * S2
38794 C = 0.0 + 0.459 * S
38795 D = 0.354 - 0.061 * S
38796 E = 4.899 + 1.678 * S
38797 ES = 2.046 + 1.389 * S
38798 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38799C...X * D = X * DBAR :
38800 AL = 1.549
38801 BE = 0.782
38802 AK = 0.496 + 0.026 * S
38803 BK = 0.685 - 0.580 * SS + 0.608 * S2
38804 AG = 0.233 + 0.302 * S
38805 BG = 0.0 - 0.818 * S + 0.198 * S2
38806 C = 0.114 + 0.154 * S
38807 D = 0.405 - 0.195 * S + 0.046 * S2
38808 E = 4.807 + 1.226 * S
38809 ES = 2.166 + 0.664 * S
38810 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38811C...X * G :
38812 AL = 0.676
38813 BE = 1.089
38814 AK = 0.462 - 0.524 * SS
38815 BK = 5.451 - 0.804 * S2
38816 AG = 0.535 - 0.504 * SS + 0.288 * S2
38817 BG = 0.364 - 0.520 * S
38818 C = -0.323 + 0.115 * S2
38819 D = 0.233 + 0.790 * S - 0.139 * S2
38820 E = 0.893 + 1.968 * S
38821 ES = 3.432 + 0.392 * S
38822 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38823C...X * S = X * SBAR :
38824 SF = 0.0
38825 AL = 1.609
38826 BE = 0.962
38827 AK = 0.470 - 0.099 * S2
38828 BK = 3.246
38829 AG = 0.121 - 0.068 * SS
38830 BG = -0.090 + 0.074 * S
38831 C = 0.062 + 0.034 * S
38832 D = 0.0 + 0.226 * S - 0.060 * S2
38833 E = 4.288 + 1.707 * S
38834 ES = 2.122 + 0.656 * S
38835 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38836C...X * C = X * CBAR :
38837 SF = 0.888
38838 AL = 0.970
38839 BE = 0.545
38840 AK = 1.254 - 0.251 * S
38841 BK = 3.932 - 0.327 * S2
38842 AG = 0.658 + 0.202 * S
38843 BG = -0.699
38844 C = 0.965
38845 D = 0.0 + 0.141 * S - 0.027 * S2
38846 E = 4.911 + 0.969 * S
38847 ES = 2.796 + 0.952 * S
38848 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38849C...X * B = X * BBAR :
38850 SF = 1.351
38851 AL = 1.016
38852 BE = 0.338
38853 AK = 1.961 - 0.370 * S
38854 BK = 0.923 + 0.119 * S
38855 AG = 0.815 + 0.207 * S
38856 BG = -2.275
38857 C = 1.480
38858 D = -0.223 + 0.173 * S
38859 E = 5.426 + 0.623 * S
38860 ES = 3.819 + 0.901 * S
38861 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38862
38863 END
38864
38865*$ CREATE PHO_DORGHO.FOR
38866*COPY PHO_DORGHO
38867CDECK ID>, PHO_DORGHO
38868 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38869 IMPLICIT DOUBLE PRECISION (A - Z)
38870 SAVE
38871
38872 MU2 = 0.3
38873 LAM2 = 0.248 * 0.248
38874 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38875 SS = SQRT (S)
38876 S2 = S * S
38877C...X * U = X * UBAR :
38878 AL = 0.583
38879 BE = 0.688
38880 AK = 0.449 - 0.025 * S - 0.071 * S2
38881 BK = 5.060 - 1.116 * SS
38882 AG = 0.103
38883 BG = 0.319 + 0.422 * S
38884 C = 1.508 + 4.792 * S - 1.963 * S2
38885 D = 1.075 + 0.222 * SS - 0.193 * S2
38886 E = 4.147 + 1.131 * S
38887 ES = 1.661 + 0.874 * S
38888 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38889C...X * D = X * DBAR :
38890 AL = 0.591
38891 BE = 0.698
38892 AK = 0.442 - 0.132 * S - 0.058 * S2
38893 BK = 5.437 - 1.916 * SS
38894 AG = 0.099
38895 BG = 0.311 - 0.059 * S
38896 C = 0.800 + 0.078 * S - 0.100 * S2
38897 D = 0.862 + 0.294 * SS - 0.184 * S2
38898 E = 4.202 + 1.352 * S
38899 ES = 1.841 + 0.990 * S
38900 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38901C...X * G :
38902 AL = 1.161
38903 BE = 1.591
38904 AK = 0.530 - 0.742 * SS + 0.025 * S2
38905 BK = 5.662
38906 AG = 0.533 - 0.281 * SS + 0.218 * S2
38907 BG = 0.025 - 0.518 * S + 0.156 * S2
38908 C = -0.282 + 0.209 * S2
38909 D = 0.107 + 1.058 * S - 0.218 * S2
38910 E = 0.0 + 2.704 * S
38911 ES = 3.071 - 0.378 * S
38912 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38913C...X * S = X * SBAR :
38914 SF = 0.0
38915 AL = 0.635
38916 BE = 0.456
38917 AK = 1.770 - 0.735 * SS - 0.079 * S2
38918 BK = 3.832
38919 AG = 0.084 - 0.023 * S
38920 BG = 0.136
38921 C = 2.119 - 0.942 * S + 0.063 * S2
38922 D = 1.271 + 0.076 * S - 0.190 * S2
38923 E = 4.604 + 0.737 * S
38924 ES = 1.641 + 0.976 * S
38925 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38926C...X * C = X * CBAR :
38927 SF = 0.820
38928 AL = 0.926
38929 BE = 0.152
38930 AK = 1.142 - 0.175 * S
38931 BK = 3.276
38932 AG = 0.504 + 0.317 * S
38933 BG = -0.433
38934 C = 3.334
38935 D = 0.398 + 0.326 * S - 0.107 * S2
38936 E = 5.493 + 0.408 * S
38937 ES = 2.426 + 1.277 * S
38938 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38939C...X * B = X * BBAR :
38940 SF = 1.297
38941 AL = 0.969
38942 BE = 0.266
38943 AK = 1.953 - 0.391 * S
38944 BK = 1.657 - 0.161 * S
38945 AG = 1.076 + 0.034 * S
38946 BG = -2.015
38947 C = 1.662
38948 D = 0.353 + 0.016 * S
38949 E = 5.713 + 0.249 * S
38950 ES = 3.456 + 0.673 * S
38951 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38952
38953 END
38954
38955*$ CREATE PHO_DORGH0.FOR
38956*COPY PHO_DORGH0
38957CDECK ID>, PHO_DORGH0
38958 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38959 IMPLICIT DOUBLE PRECISION (A - Z)
38960 SAVE
38961
38962 MU2 = 0.3
38963 LAM2 = 0.248 * 0.248
38964 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38965 SS = SQRT (S)
38966 S2 = S * S
38967C...X * U = X * UBAR :
38968 AL = 1.447
38969 BE = 0.848
38970 AK = 0.527 + 0.200 * S - 0.107 * S2
38971 BK = 7.106 - 0.310 * SS - 0.786 * S2
38972 AG = 0.197 + 0.533 * S
38973 BG = 0.062 - 0.398 * S + 0.109 * S2
38974 C = 0.755 * S - 0.112 * S2
38975 D = 0.318 - 0.059 * S
38976 E = 4.225 + 1.708 * S
38977 ES = 1.752 + 0.866 * S
38978 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38979C...X * D = X * DBAR :
38980 AL = 1.424
38981 BE = 0.770
38982 AK = 0.500 + 0.067 * SS - 0.055 * S2
38983 BK = 0.376 - 0.453 * SS + 0.405 * S2
38984 AG = 0.156 + 0.184 * S
38985 BG = 0.0 - 0.528 * S + 0.146 * S2
38986 C = 0.121 + 0.092 * S
38987 D = 0.379 - 0.301 * S + 0.081 * S2
38988 E = 4.346 + 1.638 * S
38989 ES = 1.645 + 1.016 * S
38990 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38991C...X * G :
38992 AL = 0.661
38993 BE = 0.793
38994 AK = 0.537 - 0.600 * SS
38995 BK = 6.389 - 0.953 * S2
38996 AG = 0.558 - 0.383 * SS + 0.261 * S2
38997 BG = 0.0 - 0.305 * S
38998 C = -0.222 + 0.078 * S2
38999 D = 0.153 + 0.978 * S - 0.209 * S2
39000 E = 1.429 + 1.772 * S
39001 ES = 3.331 + 0.806 * S
39002 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39003C...X * S = X * SBAR :
39004 SF = 0.0
39005 AL = 1.578
39006 BE = 0.863
39007 AK = 0.622 + 0.332 * S - 0.300 * S2
39008 BK = 2.469
39009 AG = 0.211 - 0.064 * SS - 0.018 * S2
39010 BG = -0.215 + 0.122 * S
39011 C = 0.153
39012 D = 0.0 + 0.253 * S - 0.081 * S2
39013 E = 3.990 + 2.014 * S
39014 ES = 1.720 + 0.986 * S
39015 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39016C...X * C = X * CBAR :
39017 SF = 0.820
39018 AL = 0.929
39019 BE = 0.381
39020 AK = 1.228 - 0.231 * S
39021 BK = 3.806 - 0.337 * S2
39022 AG = 0.932 + 0.150 * S
39023 BG = -0.906
39024 C = 1.133
39025 D = 0.0 + 0.138 * S - 0.028 * S2
39026 E = 5.588 + 0.628 * S
39027 ES = 2.665 + 1.054 * S
39028 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39029C...X * B = X * BBAR :
39030 SF = 1.297
39031 AL = 0.970
39032 BE = 0.207
39033 AK = 1.719 - 0.292 * S
39034 BK = 0.928 + 0.096 * S
39035 AG = 0.845 + 0.178 * S
39036 BG = -2.310
39037 C = 1.558
39038 D = -0.191 + 0.151 * S
39039 E = 6.089 + 0.282 * S
39040 ES = 3.379 + 1.062 * S
39041 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39042
39043 END
39044
39045*$ CREATE PHO_DORGF.FOR
39046*COPY PHO_DORGF
39047CDECK ID>, PHO_DORGF
39048 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39049 & AG,BG,C,D,E,ES)
39050 IMPLICIT DOUBLE PRECISION (A - Z)
39051 SAVE
39052
39053 SX = SQRT (X)
39054 LX = LOG (1./X)
39055 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39056 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39057
39058 END
39059
39060*$ CREATE PHO_DORGFS.FOR
39061*COPY PHO_DORGFS
39062CDECK ID>, PHO_DORGFS
39063 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39064 & C,D,E,ES)
39065 IMPLICIT DOUBLE PRECISION (A - Z)
39066 SAVE
39067
39068 IF (S .LE. SF) THEN
39069 PHO_DORGFS = 0.0
39070 ELSE
39071 SX = SQRT (X)
39072 LX = LOG (1./X)
39073 DS = S - SF
39074 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39075 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39076 END IF
39077
39078 END
39079
39080*$ CREATE PHO_DORGLV.FOR
39081*COPY PHO_DORGLV
39082CDECK ID>, PHO_DORGLV
39083* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39084* *
39085* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39086* *
39087* FOR A DETAILED EXPLANATION SEE *
39088* M. GLUECK, E.REYA, M. STRATMANN : *
39089* PHYS. REV. D51 (1995) 3220 *
39090* *
39091* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39092* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39093* AND (!) Q**2 > 5 P**2 *
39094* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39095* P**2 = 0 <=> REAL PHOTON *
39096* X BETWEEN 1.E-4 AND 1. *
39097* *
39098* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39099* M(C) = 1.5, M(B) = 4.5 *
39100* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39101* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39102* LAMBDA(5) = 0.153, *
39103* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39104* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39105* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39106* *
39107* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39108* Marco.Stratmann@durham.ac.uk *
39109* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39110*
39111*...INPUT PARAMETERS :
39112*
39113* X = MOMENTUM FRACTION
39114* Q2 = SCALE Q**2 IN GEV**2
39115* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39116*
39117*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39118*
39119********************************************************
39120* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39121 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39122 implicit double precision (a-z)
39123 save
39124
39125C input/output channels
39126 INTEGER LI,LO
39127 COMMON /POINOU/ LI,LO
39128
39129 integer check
39130c
39131c check limits :
39132c
39133 check=0
39134 if(x.lt.0.0001d0) check=1
39135 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39136 if(q2.lt.5.d0*p2) check=1
39137c
39138c calculate distributions
39139c
39140 if(check.eq.0) then
39141 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39142 else
39143 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39144 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39145 endif
39146
39147 end
39148
39149*$ CREATE PHO_grscalc.FOR
39150*COPY PHO_grscalc
39151CDECK ID>, PHO_grscalc
39152 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39153 implicit double precision (a-z)
39154 save
39155
39156 dimension u1(40),ds1(40),g1(40)
39157 dimension ud2(20),s2(20),g2(20)
39158 dimension up0(20),dsp0(20),gp0(20)
454792a9 39159CPH save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
9aaba0d6 39160c
39161 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39162 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39163 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39164 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39165 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39166 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39167 & 0.622d0,0.227d0,-0.184d0/
39168 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39169 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39170 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39171 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39172 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39173 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39174 & 0.245d0,-0.171d0/
39175 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39176 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39177 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39178 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39179 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39180 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39181 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39182 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39183 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39184 & -0.614d0,3.548d0/
39185 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39186 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39187 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39188 & -0.48d0,3.401d0/
39189 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39190 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39191 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39192 & -0.079d0/
39193 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39194 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39195 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39196 & 2.294d0/
39197 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39198 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39199 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39200 & 0.814d0,1.531d0,0.124d0/
39201 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39202 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39203 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39204 & 2.264d0,0.2675d0/
39205c
39206 mu2=0.25d0
39207 lam2=0.232d0*0.232d0
39208c
39209 if(p2.le.0.25d0) then
39210 s=log(log(q2/lam2)/log(mu2/lam2))
39211 lp1=0.d0
39212 lp2=0.d0
39213 else
39214 s=log(log(q2/lam2)/log(p2/lam2))
39215 lp1=log(p2/mu2)*log(p2/mu2)
39216 lp2=log(p2/mu2+log(p2/mu2))
39217 endif
39218c
39219 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39220 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39221 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39222 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39223 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39224 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39225 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39226 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39227 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39228 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39229 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39230 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39231 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39232 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39233 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39234 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39235 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39236 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39237 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39238 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39239 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39240c
39241 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39242 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39243 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39244 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39245 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39246 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39247 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39248 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39249 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39250 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39251 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39252 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39253 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39254 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39255 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39256 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39257 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39258 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39259 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39260 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39261 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39262c
39263 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39264 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39265 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39266 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39267 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39268 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39269 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39270 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39271 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39272 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39273 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39274 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39275 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39276 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39277 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39278 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39279 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39280 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39281 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39282 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39283 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39284c
39285 s=log(log(q2/lam2)/log(mu2/lam2))
39286 suppr=1.d0/(1.d0+p2/0.59d0)**2
39287c
39288 alp=ud2(1)
39289 bet=ud2(2)
39290 a=ud2(3)+ud2(4)*s
39291 ga=ud2(5)+ud2(6)*s**0.5
39292 gc=ud2(7)+ud2(8)*s
39293 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39294 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39295 gd=ud2(15)+ud2(16)*s
39296 ge=ud2(17)+ud2(18)*s
39297 gep=ud2(19)+ud2(20)*s
39298 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39299c
39300 alp=s2(1)
39301 bet=s2(2)
39302 a=s2(3)+s2(4)*s
39303 ga=s2(5)+s2(6)*s**0.5
39304 gc=s2(7)+s2(8)*s
39305 b=s2(9)+s2(10)*s+s2(11)*s**2
39306 gb=s2(12)+s2(13)*s+s2(14)*s**2
39307 gd=s2(15)+s2(16)*s
39308 ge=s2(17)+s2(18)*s
39309 gep=s2(19)+s2(20)*s
39310 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39311c
39312 alp=g2(1)
39313 bet=g2(2)
39314 a=g2(3)+g2(4)*s**0.5
39315 b=g2(5)+g2(6)*s**2
39316 gb=g2(7)+g2(8)*s
39317 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39318 gc=g2(12)+g2(13)*s**2
39319 gd=g2(14)+g2(15)*s+g2(16)*s**2
39320 ge=g2(17)+g2(18)*s
39321 gep=g2(19)+g2(20)*s
39322 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39323c
39324 ugam=upart1+udpart2
39325 dgam=dspart1+udpart2
39326 sgam=dspart1+spart2
39327 ggam=gpart1+gpart2
39328c
39329 end
39330
39331*$ CREATE PHO_grsf1.FOR
39332*COPY PHO_grsf1
39333CDECK ID>, PHO_grsf1
39334 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39335 & ge,gep)
39336 implicit double precision (a-z)
39337 save
39338
39339 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39340 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39341 & (1.d0-x)**gd
39342
39343 end
39344
39345*$ CREATE PHO_grsf2.FOR
39346*COPY PHO_grsf2
39347CDECK ID>, PHO_grsf2
39348 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39349 & ge,gep)
39350 implicit double precision (a-z)
39351 save
39352
39353 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39354 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39355 & (1.d0-x)**gd
39356
39357 end
39358
39359*$ CREATE PHO_CKMTPA.FOR
39360*COPY PHO_CKMTPA
39361CDECK ID>, PHO_CKMTPA
39362 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39363C**********************************************************************
39364C
39365C PDF based on Regge theory, evolved with .... by ....
39366C
39367C input: IPAR 2212 proton (not installed)
39368C 990 Pomeron
39369C
39370C output: parameters of parametrization
39371C
39372C**********************************************************************
39373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39374 SAVE
39375
39376 CHARACTER*8 PDFNA
39377
39378C input/output channels
39379 INTEGER LI,LO
39380 COMMON /POINOU/ LI,LO
39381
39382 REAL PROP(40),POMP(40)
39383 DATA PROP /
39384 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39385 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39386 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39387 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39388 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39389 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39390 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39391 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39392 DATA POMP /
39393 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39394 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39395 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39396 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39397 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39398 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39399 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39400 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39401
39402 IF(IPA.EQ.2212) THEN
39403 ALA =PROP(1)
39404 Q2MI = PROP(39)
39405 Q2MA = PROP(40)
39406 PDFNA = 'CKMT-PRO'
39407 ELSE IF(IPA.EQ.990) THEN
39408 ALA = POMP(1)
39409 Q2MI = POMP(39)
39410 Q2MA = POMP(40)
39411 PDFNA = 'CKMT-POM'
39412 ELSE
39413 WRITE(LO,'(1X,A,I7)')
39414 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39415 STOP
39416 ENDIF
39417 XMI = 1.D-4
39418 XMA = 1.D0
39419 END
39420
39421*$ CREATE PHO_CKMTPD.FOR
39422*COPY PHO_CKMTPD
39423CDECK ID>, PHO_CKMTPD
39424 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39425C**********************************************************************
39426C
39427C PDF based on Regge theory, evolved with .... by ....
39428C
39429C input: IPAR 2212 proton (not installed)
39430C 990 Pomeron
39431C
39432C output: PD(-6:6) x*f(x) parton distribution functions
39433C (PDFLIB convention: d = PD(1), u = PD(2) )
39434C
39435C**********************************************************************
39436 SAVE
39437
39438C input/output channels
39439 INTEGER LI,LO
39440 COMMON /POINOU/ LI,LO
39441
39442 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39443 DIMENSION QQ(7)
39444
39445 Q2=SNGL(SCALE2)
39446 Q1S=Q2
39447 XX=SNGL(X)
39448C QCD lambda for evolution
39449 OWLAM = 0.23D0
39450 OWLAM2=OWLAM**2
39451C Q0**2 for evolution
39452 Q02 = 2.D0
39453C
39454C
39455C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39456C q(6)=x*charm, q(7)=x*gluon
39457C
39458 SB=0.
39459 IF(Q2-Q02) 1,1,2
39460 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39461 1 CONTINUE
39462 IF(IPAR.EQ.2212) THEN
39463* CALL PHO_CKMTPR(XX,SB,QQ
39464 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39465 CALL PHO_ABORT
39466 ELSE
39467 CALL PHO_CKMTPO(XX,SB,QQ)
39468 ENDIF
39469C
39470 PD(-6) = 0.D0
39471 PD(-5) = 0.D0
39472 PD(-4) = DBLE(QQ(6))
39473 PD(-3) = DBLE(QQ(3))
39474 PD(-2) = DBLE(QQ(4))
39475 PD(-1) = DBLE(QQ(5))
39476 PD(0) = DBLE(QQ(7))
39477 PD(1) = DBLE(QQ(2))
39478 PD(2) = DBLE(QQ(1))
39479 PD(3) = DBLE(QQ(3))
39480 PD(4) = DBLE(QQ(6))
39481 PD(5) = 0.D0
39482 PD(6) = 0.D0
39483 IF(IPAR.EQ.990) THEN
39484 CDN = (PD(1)-PD(-1))/2.D0
39485 CUP = (PD(2)-PD(-2))/2.D0
39486 PD(-1) = PD(-1) + CDN
39487 PD(-2) = PD(-2) + CUP
39488 PD(1) = PD(-1)
39489 PD(2) = PD(-2)
39490 ENDIF
39491 END
39492
39493*$ CREATE PHO_CKMTPO.FOR
39494*COPY PHO_CKMTPO
39495CDECK ID>, PHO_CKMTPO
39496 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39497C**********************************************************************
39498C
39499C calculation partons in Pomeron
39500C
39501C**********************************************************************
39502 SAVE
39503
39504 DIMENSION QQ(7)
39505
39506C input/output channels
39507 INTEGER LI,LO
39508 COMMON /POINOU/ LI,LO
39509
39510 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39511 EQUIVALENCE (GF(1,1,1),DL(1))
39512 DATA DELTA/.10/
39513
39514C RNG= -.5
39515C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39516C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39517 DATA (DL(K),K= 1, 85) /
39518 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39519 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39520 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39521 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39522 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39523 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39524 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39525 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39526 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39527 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39528 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39529 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39530 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39531 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39532 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39533 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39534 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39535 DATA (DL(K),K= 86, 170) /
39536 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39537 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39538 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39539 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39540 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39541 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39542 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39543 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39544 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39545 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39546 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39547 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39548 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39549 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39550 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39551 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39552 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39553 DATA (DL(K),K= 171, 255) /
39554 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39555 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39556 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39557 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39558 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39559 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39560 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39561 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39562 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39563 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39564 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39565 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39566 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39567 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39568 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39569 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39570 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39571 DATA (DL(K),K= 256, 340) /
39572 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39573 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39574 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39575 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39576 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39577 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39578 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39579 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39580 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39581 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39582 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39583 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39584 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39585 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39586 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39587 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39588 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39589 DATA (DL(K),K= 341, 425) /
39590 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39591 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39592 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39593 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39594 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39595 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39596 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39597 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39598 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39599 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39600 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39601 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39602 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39603 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39604 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39605 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39606 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39607 DATA (DL(K),K= 426, 510) /
39608 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39609 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39610 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39611 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39612 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39613 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39614 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39615 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39616 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39617 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39618 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39619 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39620 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39621 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39622 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39623 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39624 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39625 DATA (DL(K),K= 511, 595) /
39626 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39627 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39628 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39629 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39630 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39631 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39632 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39633 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39634 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39635 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39636 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39637 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39638 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39639 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39640 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39641 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39642 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39643 DATA (DL(K),K= 596, 680) /
39644 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39645 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39646 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39647 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39648 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39649 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39650 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39651 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39652 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39653 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39654 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39655 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39656 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39657 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39658 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39659 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39660 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39661 DATA (DL(K),K= 681, 765) /
39662 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39663 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39664 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39665 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39666 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39667 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39668 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39669 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39670 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39671 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39672 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39673 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39674 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39675 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39676 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39677 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39678 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39679 DATA (DL(K),K= 766, 850) /
39680 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39681 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39682 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39683 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39684 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39685 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39686 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39687 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39688 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39689 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39690 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39691 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39692 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39693 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39694 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39695 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39696 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39697 DATA (DL(K),K= 851, 935) /
39698 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39699 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39700 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39701 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39702 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39703 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39704 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39705 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39706 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39707 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39708 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39709 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39710 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39711 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39712 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39713 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39714 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39715 DATA (DL(K),K= 936, 1020) /
39716 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39717 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39718 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39719 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39720 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39721 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39722 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39723 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39724 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39725 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39726 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39727 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39728 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39729 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39730 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39731 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39732 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39733 DATA (DL(K),K= 1021, 1105) /
39734 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39735 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39736 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39737 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39738 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39739 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39740 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39741 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39742 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39743 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39744 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39745 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39746 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39747 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39748 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39749 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39750 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39751 DATA (DL(K),K= 1106, 1190) /
39752 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39753 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39754 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39755 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39756 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39757 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39758 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39759 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39760 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39761 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39762 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39763 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39764 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39765 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39766 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39767 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39768 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39769 DATA (DL(K),K= 1191, 1275) /
39770 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39771 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39772 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39773 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39774 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39775 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39776 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39777 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39778 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39779 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39780 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39781 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39782 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39783 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39784 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39785 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39786 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39787 DATA (DL(K),K= 1276, 1360) /
39788 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39789 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39790 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39791 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39792 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39793 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39794 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39795 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39796 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39797 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39798 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39799 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39800 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39801 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39802 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39803 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39804 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39805 DATA (DL(K),K= 1361, 1445) /
39806 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39807 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39808 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39809 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39810 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39811 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39812 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39813 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39814 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39815 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39816 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39817 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39818 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39819 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39820 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39821 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39822 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39823 DATA (DL(K),K= 1446, 1530) /
39824 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39825 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39826 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39827 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39828 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39829 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39830 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39831 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39832 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39833 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39834 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39835 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39836 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39837 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39838 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39839 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39840 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39841 DATA (DL(K),K= 1531, 1615) /
39842 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39843 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39844 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39845 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39846 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39847 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39848 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39849 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39850 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39851 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39852 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39853 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39854 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39855 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39856 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39857 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39858 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39859 DATA (DL(K),K= 1616, 1700) /
39860 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39861 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39862 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39863 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39864 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39865 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39866 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39867 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39868 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39869 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39870 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39871 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39872 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39873 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39874 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39875 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39876 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39877 DATA (DL(K),K= 1701, 1785) /
39878 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39879 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39880 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39881 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39882 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39883 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39884 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39885 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39886 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39887 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39888 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39889 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39890 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39891 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39892 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39893 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39894 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39895 DATA (DL(K),K= 1786, 1870) /
39896 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39897 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39898 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39899 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39900 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39901 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39902 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39903 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39904 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39905 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39906 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39907 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39908 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39909 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39910 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39911 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39912 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39913 DATA (DL(K),K= 1871, 1955) /
39914 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39915 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39916 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39917 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39918 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39919 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39920 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39921 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39922 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39923 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39924 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39925 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39926 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39927 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39928 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39929 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39930 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39931 DATA (DL(K),K= 1956, 2040) /
39932 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39933 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39934 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39935 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39936 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39937 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39938 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39939 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39940 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39941 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39942 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39943 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39944 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39945 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39946 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39947 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39948 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39949 DATA (DL(K),K= 2041, 2125) /
39950 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39951 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39952 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39953 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39954 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39955 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39956 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39957 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39958 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39959 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39960 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39961 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39962 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39963 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39964 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39965 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39966 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39967 DATA (DL(K),K= 2126, 2210) /
39968 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39969 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39970 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39971 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39972 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39973 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39974 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39975 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39976 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39977 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39978 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39979 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39980 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39981 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39982 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39983 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39984 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39985 DATA (DL(K),K= 2211, 2295) /
39986 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39987 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39988 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39989 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39990 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39991 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39992 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39993 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39994 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39995 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39996 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39997 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39998 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39999 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40000 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40001 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40002 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40003 DATA (DL(K),K= 2296, 2380) /
40004 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40005 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40006 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40007 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40008 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40009 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40010 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40011 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40012 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40013 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40014 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40015 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40016 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40017 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40018 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40019 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40020 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40021 DATA (DL(K),K= 2381, 2465) /
40022 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40023 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40024 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40025 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40026 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40027 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40028 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40029 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40030 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40031 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40032 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40033 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40034 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40035 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40036 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40037 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40038 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40039 DATA (DL(K),K= 2466, 2550) /
40040 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40041 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40042 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40043 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40044 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40045 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40046 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40047 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40048 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40049 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40050 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40051 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40052 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40053 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40054 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40055 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40056 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40057 DATA (DL(K),K= 2551, 2635) /
40058 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40059 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40060 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40061 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40062 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40063 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40064 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40065 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40066 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40067 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40068 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40069 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40070 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40071 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40072 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40073 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40074 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40075 DATA (DL(K),K= 2636, 2720) /
40076 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40077 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40078 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40079 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40080 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40081 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40082 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40083 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40084 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40085 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40086 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40087 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40088 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40089 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40090 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40091 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40092 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40093 DATA (DL(K),K= 2721, 2805) /
40094 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40095 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40096 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40097 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40098 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40099 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40100 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40101 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40102 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40103 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40104 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40105 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40106 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40107 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40108 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40109 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40110 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40111 DATA (DL(K),K= 2806, 2890) /
40112 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40113 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40114 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40115 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40116 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40117 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40118 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40119 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40120 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40121 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40122 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40123 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40124 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40125 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40126 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40127 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40128 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40129 DATA (DL(K),K= 2891, 2975) /
40130 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40131 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40132 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40133 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40134 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40135 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40136 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40137 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40138 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40139 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40140 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40141 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40142 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40143 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40144 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40145 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40146 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40147 DATA (DL(K),K= 2976, 3060) /
40148 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40149 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40150 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40151 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40152 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40153 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40154 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40155 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40156 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40157 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40158 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40159 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40160 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40161 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40162 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40163 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40164 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40165 DATA (DL(K),K= 3061, 3145) /
40166 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40167 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40168 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40169 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40170 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40171 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40172 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40173 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40174 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40175 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40176 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40177 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40178 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40179 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40180 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40181 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40182 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40183 DATA (DL(K),K= 3146, 3230) /
40184 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40185 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40186 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40187 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40188 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40189 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40190 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40191 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40192 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40193 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40194 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40195 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40196 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40197 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40198 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40199 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40200 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40201 DATA (DL(K),K= 3231, 3315) /
40202 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40203 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40204 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40205 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40206 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40207 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40208 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40209 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40210 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40211 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40212 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40213 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40214 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40215 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40216 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40217 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40218 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40219 DATA (DL(K),K= 3316, 3400) /
40220 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40221 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40222 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40223 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40224 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40225 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40226 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40227 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40228 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40229 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40230 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40231 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40232 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40233 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40234 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40235 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40236 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40237 DATA (DL(K),K= 3401, 3485) /
40238 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40239 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40240 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40241 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40242 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40243 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40244 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40245 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40246 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40247 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40248 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40249 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40250 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40251 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40252 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40253 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40254 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40255 DATA (DL(K),K= 3486, 3570) /
40256 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40257 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40258 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40259 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40260 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40261 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40262 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40263 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40264 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40265 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40266 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40267 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40268 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40269 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40270 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40271 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40272 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40273 DATA (DL(K),K= 3571, 3655) /
40274 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40275 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40276 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40277 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40278 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40279 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40280 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40281 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40282 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40283 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40284 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40285 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40286 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40287 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40288 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40289 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40290 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40291 DATA (DL(K),K= 3656, 3740) /
40292 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40293 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40294 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40295 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40296 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40297 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40298 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40299 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40300 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40301 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40302 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40303 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40304 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40305 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40306 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40307 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40308 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40309 DATA (DL(K),K= 3741, 3825) /
40310 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40311 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40312 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40313 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40314 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40315 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40316 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40317 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40318 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40319 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40320 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40321 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40322 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40323 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40324 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40325 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40326 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40327 DATA (DL(K),K= 3826, 3910) /
40328 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40329 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40330 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40331 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40332 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40333 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40334 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40335 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40336 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40337 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40338 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40339 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40340 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40341 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40342 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40343 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40344 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40345 DATA (DL(K),K= 3911, 3995) /
40346 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40347 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40348 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40349 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40350 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40351 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40352 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40353 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40354 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40355 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40356 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40357 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40358 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40359 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40360 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40361 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40362 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40363 DATA (DL(K),K= 3996, 4000) /
40364 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40365
40366 DO 10 I=1,7
40367 QQ(I) = 0.
40368 10 CONTINUE
40369 IF(X.GT.0.9985) RETURN
40370
40371 IS = S/DELTA+1
40372 IS = MIN(IS,19)
40373 IS1 = IS+1
40374 DO 20 I=1,7
40375 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40376 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40377 DO 30 L=1,25
40378 F1(L)=GF(I,IS,L)
40379 F2(L)=GF(I,IS1,L)
40380 30 CONTINUE
40381 S1=(IS-1)*DELTA
40382 S2=S1+DELTA
40383 A1 = PHO_CKMTFV(X,F1)
40384 A2 = PHO_CKMTFV(X,F2)
40385 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40386 19 CONTINUE
40387 20 CONTINUE
40388
40389 END
40390
40391*$ CREATE PHO_CKMTFV.FOR
40392*COPY PHO_CKMTFV
40393CDECK ID>, PHO_CKMTFV
40394 REAL FUNCTION PHO_CKMTFV(X,FVL)
40395C**********************************************************************
40396C
40397C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40398C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40399C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40400C IN MAIN ROUTINE.
40401C
40402C**********************************************************************
40403 SAVE
40404
40405 DIMENSION FVL(25),XGRID(25)
40406
40407C input/output channels
40408 INTEGER LI,LO
40409 COMMON /POINOU/ LI,LO
40410
40411 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40412 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40413
40414 PHO_CKMTFV=0.
40415 DO 1 I=1,NX
40416 IF(X.LT.XGRID(I)) GO TO 2
40417 1 CONTINUE
40418 2 I=I-1
40419 IF(I.EQ.0) THEN
40420 I=I+1
40421 ELSE IF(I.GT.23) THEN
40422 I=23
40423 ENDIF
40424 J=I+1
40425 K=J+1
40426 AXI=LOG(XGRID(I))
40427 BXI=LOG(1.-XGRID(I))
40428 AXJ=LOG(XGRID(J))
40429 BXJ=LOG(1.-XGRID(J))
40430 AXK=LOG(XGRID(K))
40431 BXK=LOG(1.-XGRID(K))
40432 FI=LOG(ABS(FVL(I)) +1.E-15)
40433 FJ=LOG(ABS(FVL(J)) +1.E-16)
40434 FK=LOG(ABS(FVL(K)) +1.E-17)
40435 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40436 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40437 $ BXI))/DET
40438 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40439 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40440 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40441 1RETURN
40442C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40443C WRITE(LO,2001) X,FVL
40444C 2001 FORMAT(8E12.4)
40445C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40446C ENDIF
40447 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40448
40449 END
40450
40451*$ CREATE PHO_SASGAM.FOR
40452*COPY PHO_SASGAM
40453CDECK ID>, PHO_SASGAM
40454C***********************************************************************
40455C...SaSgam version 2 - parton distributions of the photon
40456C...by Gerhard A. Schuler and Torbjorn Sjostrand
40457C...For further information see Z. Phys. C68 (1995) 607
40458C...and Phys. Lett. B376 (1996) 193.
40459
40460C...18 January 1996: original code.
40461C...22 July 1996: calculation of BETA moved in SASBEH.
40462
40463C!!!Note that one further call parameter - IP2 - has been added
40464C!!!to the SASGAM argument list compared with version 1.
40465
40466C...The user should only need to call the SASGAM routine,
40467C...which in turn calls the auxiliary routines SASVMD, SASANO,
40468C...SASBEH and SASDIR. The package is self-contained.
40469
40470C...One particular aspect of these parametrizations is that F2 for
40471C...the photon is not obtained just as the charge-squared-weighted
40472C...sum of quark distributions, but differ in the treatment of
40473C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40474C...the kinematics range of heavy-flavour production, but the same
40475C...kinematics is not relevant e.g. for jet production) and, for the
40476C...'MSbar' fits, in the addition of a Cgamma term related to the
40477C...separation of direct processes. Schematically:
40478C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40479C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40480C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40481C...The J/psi and Upsilon states have not been included in the VMD sum,
40482C...but low c and b masses in the other components should compensate
40483C...for this in a duality sense.
40484
40485C...The calling sequence is the following:
40486C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40487C...with the following declaration statement:
40488C DIMENSION XPDFGM(-6:6)
40489C...and, optionally, further information in:
40490C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40491C &XPDIR(-6:6)
40492C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40493C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40494C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40495C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40496C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40497C X : x value.
40498C Q2 : Q2 value.
40499C P2 : P2 value; should be = 0. for an on-shell photon.
40500C IP2 : scheme used to evaluate off-shell anomalous component.
40501C = 0 : recommended default, see = 7.
40502C = 1 : dipole dampening by integration; very time-consuming.
40503C = 2 : P_0^2 = max( Q_0^2, P^2 )
40504C = 3 : P_0^2 = Q_0^2 + P^2.
40505C = 4 : P_{eff} that preserves momentum sum.
40506C = 5 : P_{int} that preserves momentum and average
40507C evolution range.
40508C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40509C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40510C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40511C XPFDGM : x times parton distribution functions of the photon,
40512C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40513C 6 = t (always empty!), - for antiquarks (result is same).
40514C...The breakdown by component is stored in the commonblock SASCOM,
40515C with elements as above.
40516C XPVMD : rho, omega, phi VMD part only of output.
40517C XPANL : d, u, s anomalous part only of output.
40518C XPANH : c, b anomalous part only of output.
40519C XPBEH : c, b Bethe-Heitler part only of output.
40520C XPDIR : Cgamma (direct contribution) part only of output.
40521C...The above arrays do not distinguish valence and sea contributions,
40522C...although this information is available internally. The additional
40523C...commonblock SASVAL provides the valence part only of the above
40524C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40525C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40526C...and therefore not given doubly. VXPDGM gives the sum of valence
40527C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40528C...and so on, gives the sea part only.
40529C***********************************************************************
40530
40531 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40532C...Purpose: to construct the F2 and parton distributions of the photon
40533C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40534C...For F2, c and b are included by the Bethe-Heitler formula;
40535C...in the 'MSbar' scheme additionally a Cgamma term is added.
40536 SAVE
40537 DIMENSION XPDFGM(-6:6)
40538
40539C input/output channels
40540 INTEGER LI,LO
40541 COMMON /POINOU/ LI,LO
40542
40543 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40544 &XPDIR(-6:6)
40545 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
454792a9 40546CPH SAVE /SASCOM/,/SASVAL/
9aaba0d6 40547
40548C...Temporary array.
40549 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40550C...Charm and bottom masses (low to compensate for J/psi etc.).
40551 DATA PMC/1.3/, PMB/4.6/
40552C...alpha_em and alpha_em/(2*pi).
40553 DATA AEM/0.007297/, AEM2PI/0.0011614/
40554C...Lambda value for 4 flavours.
40555 DATA ALAM/0.20/
40556C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40557 DATA FRACU/0.8/
40558C...VMD couplings f_V**2/(4*pi).
40559 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40560C...Masses for rho (=omega) and phi.
40561 DATA PMRHO/0.770/, PMPHI/1.020/
40562C...Number of points in integration for IP2=1.
40563 DATA NSTEP/100/
40564
40565C...Reset output.
40566 F2GM=0.
40567 DO 100 KFL=-6,6
40568 XPDFGM(KFL)=0.
40569 XPVMD(KFL)=0.
40570 XPANL(KFL)=0.
40571 XPANH(KFL)=0.
40572 XPBEH(KFL)=0.
40573 XPDIR(KFL)=0.
40574 VXPVMD(KFL)=0.
40575 VXPANL(KFL)=0.
40576 VXPANH(KFL)=0.
40577 VXPDGM(KFL)=0.
40578 100 CONTINUE
40579
40580C...Check that input sensible.
40581 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40582 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40583 WRITE(LO,*) ' ISET = ',ISET
40584 STOP
40585 ENDIF
40586 IF(X.LE.0..OR.X.GT.1.) THEN
40587 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40588 WRITE(LO,*) ' X = ',X
40589 STOP
40590 ENDIF
40591
40592C...Set Q0 cut-off parameter as function of set used.
40593 IF(ISET.LE.2) THEN
40594 Q0=0.6
40595 ELSE
40596 Q0=2.
40597 ENDIF
40598 Q02=Q0**2
40599
40600C...Scale choice for off-shell photon; common factors.
40601 Q2A=Q2
40602 FACNOR=1.
40603 IF(IP2.EQ.1) THEN
40604 P2MX=P2+Q02
40605 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40606 FACNOR=LOG(Q2/Q02)/NSTEP
40607 ELSEIF(IP2.EQ.2) THEN
40608 P2MX=MAX(P2,Q02)
40609 ELSEIF(IP2.EQ.3) THEN
40610 P2MX=P2+Q02
40611 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40612 ELSEIF(IP2.EQ.4) THEN
40613 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40614 & ((Q2+P2)*(Q02+P2)))
40615 ELSEIF(IP2.EQ.5) THEN
40616 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40617 & ((Q2+P2)*(Q02+P2)))
40618 P2MX=Q0*SQRT(P2MXA)
40619 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40620 ELSEIF(IP2.EQ.6) THEN
40621 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40622 & ((Q2+P2)*(Q02+P2)))
40623 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40624 ELSE
40625 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40626 & ((Q2+P2)*(Q02+P2)))
40627 P2MX=Q0*SQRT(P2MXA)
40628 P2MXB=P2MX
40629 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40630 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40631 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40632 ENDIF
40633
40634C...Call VMD parametrization for d quark and use to give rho, omega,
40635C...phi. Note dipole dampening for off-shell photon.
40636 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40637 XFVAL=VXPGA(1)
40638 XPGA(1)=XPGA(2)
40639 XPGA(-1)=XPGA(-2)
40640 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40641 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40642 DO 110 KFL=-5,5
40643 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40644 110 CONTINUE
40645 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40646 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40647 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40648 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40649 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40650 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40651 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40652 VXPVMD(2)=FRACU*FACUD*XFVAL
40653 VXPVMD(3)=FACS*XFVAL
40654 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40655 VXPVMD(-2)=FRACU*FACUD*XFVAL
40656 VXPVMD(-3)=FACS*XFVAL
40657
40658 IF(IP2.NE.1) THEN
40659C...Anomalous parametrizations for different strategies
40660C...for off-shell photons; except full integration.
40661
40662C...Call anomalous parametrization for d + u + s.
40663 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40664 DO 120 KFL=-5,5
40665 XPANL(KFL)=FACNOR*XPGA(KFL)
40666 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40667 120 CONTINUE
40668
40669C...Call anomalous parametrization for c and b.
40670 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40671 DO 130 KFL=-5,5
40672 XPANH(KFL)=FACNOR*XPGA(KFL)
40673 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40674 130 CONTINUE
40675 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40676 DO 140 KFL=-5,5
40677 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40678 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40679 140 CONTINUE
40680
40681 ELSE
40682C...Special option: loop over flavours and integrate over k2.
40683 DO 170 KF=1,5
40684 DO 160 ISTEP=1,NSTEP
40685 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40686 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40687 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40688 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40689 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40690 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40691 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40692 DO 150 KFL=-5,5
40693 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40694 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40695 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40696 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40697 150 CONTINUE
40698 160 CONTINUE
40699 170 CONTINUE
40700 ENDIF
40701
40702C...Call Bethe-Heitler term expression for charm and bottom.
40703 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40704 XPBEH(4)=XPBH
40705 XPBEH(-4)=XPBH
40706 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40707 XPBEH(5)=XPBH
40708 XPBEH(-5)=XPBH
40709
40710C...For MSbar subtraction call C^gamma term expression for d, u, s.
40711 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40712 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40713 DO 180 KFL=-5,5
40714 XPDIR(KFL)=XPGA(KFL)
40715 180 CONTINUE
40716 ENDIF
40717
40718C...Store result in output array.
40719 DO 190 KFL=-5,5
40720 CHSQ=1./9.
40721 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40722 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40723 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40724 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40725 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40726 190 CONTINUE
40727
40728 RETURN
40729 END
40730
40731C*********************************************************************
40732
40733*$ CREATE PHO_SASVMD.FOR
40734*COPY PHO_SASVMD
40735CDECK ID>, PHO_SASVMD
40736 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40737C...Purpose: to evaluate the VMD parton distributions of a photon,
40738C...evolved homogeneously from an initial scale P2 to Q2.
40739C...Does not include dipole suppression factor.
40740C...ISET is parton distribution set, see above;
40741C...additionally ISET=0 is used for the evolution of an anomalous photon
40742C...which branched at a scale P2 and then evolved homogeneously to Q2.
40743C...ALAM is the 4-flavour Lambda, which is automatically converted
40744C...to 3- and 5-flavour equivalents as needed.
40745 SAVE
40746 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40747
40748C input/output channels
40749 INTEGER LI,LO
40750 COMMON /POINOU/ LI,LO
40751
40752 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40753
40754C...Reset output.
40755 DO 100 KFL=-6,6
40756 XPGA(KFL)=0.
40757 VXPGA(KFL)=0.
40758 100 CONTINUE
40759 KFA=IABS(KF)
40760
40761C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40762 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40763 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40764 P2EFF=MAX(P2,1.2*ALAM3**2)
40765 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40766 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40767 Q2EFF=MAX(Q2,P2EFF)
40768
40769C...Find number of flavours at lower and upper scale.
40770 NFP=4
40771 IF(P2EFF.LT.PMC**2) NFP=3
40772 IF(P2EFF.GT.PMB**2) NFP=5
40773 NFQ=4
40774 IF(Q2EFF.LT.PMC**2) NFQ=3
40775 IF(Q2EFF.GT.PMB**2) NFQ=5
40776
40777C...Find s as sum of 3-, 4- and 5-flavour parts.
40778 S=0.
40779 IF(NFP.EQ.3) THEN
40780 Q2DIV=PMC**2
40781 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40782 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40783 ENDIF
40784 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40785 P2DIV=P2EFF
40786 IF(NFP.EQ.3) P2DIV=PMC**2
40787 Q2DIV=Q2EFF
40788 IF(NFQ.EQ.5) Q2DIV=PMB**2
40789 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40790 ENDIF
40791 IF(NFQ.EQ.5) THEN
40792 P2DIV=PMB**2
40793 IF(NFP.EQ.5) P2DIV=P2EFF
40794 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40795 ENDIF
40796
40797C...Calculate frequent combinations of x and s.
40798 X1=1.-X
40799 XL=-LOG(X)
40800 S2=S**2
40801 S3=S**3
40802 S4=S**4
40803
40804C...Evaluate homogeneous anomalous parton distributions below or
40805C...above threshold.
40806 IF(ISET.EQ.0) THEN
40807 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40808 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40809 XVAL = X * 1.5 * (X**2+X1**2)
40810 XGLU = 0.
40811 XSEA = 0.
40812 ELSE
40813 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40814 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40815 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40816 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40817 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40818 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40819 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40820 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40821 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40822 & (2.*X-1.)*X*XL**2)
40823 ENDIF
40824
40825C...Evaluate set 1D parton distributions below or above threshold.
40826 ELSEIF(ISET.EQ.1) THEN
40827 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40828 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40829 XVAL = 1.294 * X**0.80 * X1**0.76
40830 XGLU = 1.273 * X**0.40 * X1**1.76
40831 XSEA = 0.100 * X1**3.76
40832 ELSE
40833 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40834 & X1**(0.76+0.667*S) * XL**(2.*S)
40835 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40836 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40837 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40838 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40839 & X**(-7.32*S2/(1.+10.3*S2)) *
40840 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40841 XSEA0 = 0.100 * X1**3.76
40842 ENDIF
40843
40844C...Evaluate set 1M parton distributions below or above threshold.
40845 ELSEIF(ISET.EQ.2) THEN
40846 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40847 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40848 XVAL = 0.8477 * X**0.51 * X1**1.37
40849 XGLU = 3.42 * X**0.255 * X1**2.37
40850 XSEA = 0.
40851 ELSE
40852 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40853 & * X1**1.37 * XL**(2.667*S)
40854 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40855 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40856 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40857 & X1**(2.37+3.*S)
40858 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40859 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40860 & XL**(2.8*S)
40861 XSEA0 = 0.
40862 ENDIF
40863
40864C...Evaluate set 2D parton distributions below or above threshold.
40865 ELSEIF(ISET.EQ.3) THEN
40866 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40867 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40868 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40869 XGLU = 1.925 * X1**2
40870 XSEA = 0.242 * X1**4
40871 ELSE
40872 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40873 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40874 & (0.76+0.4*S) * X * X1**(2.667*S)
40875 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40876 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40877 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40878 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40879 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40880 XSEA0 = 0.242 * X1**4
40881 ENDIF
40882
40883C...Evaluate set 2M parton distributions below or above threshold.
40884 ELSEIF(ISET.EQ.4) THEN
40885 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40886 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40887 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40888 XGLU = 1.808 * X1**2
40889 XSEA = 0.209 * X1**4
40890 ELSE
40891 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40892 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40893 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40894 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40895 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40896 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40897 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40898 & XL**(10.9*S/(1.+2.5*S))
40899 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40900 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40901 & X1**(4.+S) * XL**(0.45*S)
40902 XSEA0 = 0.209 * X1**4
40903 ENDIF
40904 ENDIF
40905
40906C...Threshold factors for c and b sea.
40907 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40908 XCHM=0.
40909 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40910 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40911 IF(ISET.EQ.0) THEN
40912 XCHM=XSEA*(1.-(SCH/SLL)**2)
40913 ELSE
40914 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40915 ENDIF
40916 ENDIF
40917 XBOT=0.
40918 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40919 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40920 IF(ISET.EQ.0) THEN
40921 XBOT=XSEA*(1.-(SBT/SLL)**2)
40922 ELSE
40923 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40924 ENDIF
40925 ENDIF
40926
40927C...Fill parton distributions.
40928 XPGA(0)=XGLU
40929 XPGA(1)=XSEA
40930 XPGA(2)=XSEA
40931 XPGA(3)=XSEA
40932 XPGA(4)=XCHM
40933 XPGA(5)=XBOT
40934 XPGA(KFA)=XPGA(KFA)+XVAL
40935 DO 110 KFL=1,5
40936 XPGA(-KFL)=XPGA(KFL)
40937 110 CONTINUE
40938 VXPGA(KFA)=XVAL
40939 VXPGA(-KFA)=XVAL
40940
40941 RETURN
40942 END
40943
40944C*********************************************************************
40945
40946*$ CREATE PHO_SASANO.FOR
40947*COPY PHO_SASANO
40948CDECK ID>, PHO_SASANO
40949 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40950C...Purpose: to evaluate the parton distributions of the anomalous
40951C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40952C...to Q2.
40953C...KF=0 gives the sum over (up to) 5 flavours,
40954C...KF<0 limits to flavours up to abs(KF),
40955C...KF>0 is for flavour KF only.
40956C...ALAM is the 4-flavour Lambda, which is automatically converted
40957C...to 3- and 5-flavour equivalents as needed.
40958 SAVE
40959
40960C input/output channels
40961 INTEGER LI,LO
40962 COMMON /POINOU/ LI,LO
40963
40964 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40965 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40966
40967C...Reset output.
40968 DO 100 KFL=-6,6
40969 XPGA(KFL)=0.
40970 VXPGA(KFL)=0.
40971 100 CONTINUE
40972 IF(Q2.LE.P2) RETURN
40973 KFA=IABS(KF)
40974
40975C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40976 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40977 ALAMSQ(4)=ALAM**2
40978 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40979 P2EFF=MAX(P2,1.2*ALAMSQ(3))
40980 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40981 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40982 Q2EFF=MAX(Q2,P2EFF)
40983 XL=-LOG(X)
40984
40985C...Find number of flavours at lower and upper scale.
40986 NFP=4
40987 IF(P2EFF.LT.PMC**2) NFP=3
40988 IF(P2EFF.GT.PMB**2) NFP=5
40989 NFQ=4
40990 IF(Q2EFF.LT.PMC**2) NFQ=3
40991 IF(Q2EFF.GT.PMB**2) NFQ=5
40992
40993C...Define range of flavour loop.
40994 IF(KF.EQ.0) THEN
40995 KFLMN=1
40996 KFLMX=5
40997 ELSEIF(KF.LT.0) THEN
40998 KFLMN=1
40999 KFLMX=KFA
41000 ELSE
41001 KFLMN=KFA
41002 KFLMX=KFA
41003 ENDIF
41004
41005C...Loop over flavours the photon can branch into.
41006 DO 110 KFL=KFLMN,KFLMX
41007
41008C...Light flavours: calculate t range and (approximate) s range.
41009 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41010 TDIFF=LOG(Q2EFF/P2EFF)
41011 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41012 & LOG(P2EFF/ALAMSQ(NFQ)))
41013 IF(NFQ.GT.NFP) THEN
41014 Q2DIV=PMB**2
41015 IF(NFQ.EQ.4) Q2DIV=PMC**2
41016 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41017 & LOG(P2EFF/ALAMSQ(NFQ)))
41018 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41019 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41020 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41021 ENDIF
41022 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41023 Q2DIV=PMC**2
41024 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41025 & LOG(P2EFF/ALAMSQ(4)))
41026 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41027 & LOG(P2EFF/ALAMSQ(3)))
41028 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41029 ENDIF
41030
41031C...u and s quark do not need a separate treatment when d has been done.
41032 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41033
41034C...Charm: as above, but only include range above c threshold.
41035 ELSEIF(KFL.EQ.4) THEN
41036 IF(Q2.LE.PMC**2) GOTO 110
41037 P2EFF=MAX(P2EFF,PMC**2)
41038 Q2EFF=MAX(Q2EFF,P2EFF)
41039 TDIFF=LOG(Q2EFF/P2EFF)
41040 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41041 & LOG(P2EFF/ALAMSQ(NFQ)))
41042 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41043 Q2DIV=PMB**2
41044 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41045 & LOG(P2EFF/ALAMSQ(NFQ)))
41046 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41047 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41048 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41049 ENDIF
41050
41051C...Bottom: as above, but only include range above b threshold.
41052 ELSEIF(KFL.EQ.5) THEN
41053 IF(Q2.LE.PMB**2) GOTO 110
41054 P2EFF=MAX(P2EFF,PMB**2)
41055 Q2EFF=MAX(Q2,P2EFF)
41056 TDIFF=LOG(Q2EFF/P2EFF)
41057 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41058 & LOG(P2EFF/ALAMSQ(NFQ)))
41059 ENDIF
41060
41061C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41062 CHSQ=1./9.
41063 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41064 FAC=AEM2PI*2.*CHSQ*TDIFF
41065
41066C...Evaluate parton distributions (normalized to unit momentum sum).
41067 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41068 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41069 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41070 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41071 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41072 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41073 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41074 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41075 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41076 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41077 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41078 & (2.*X-1.)*X*XL**2)
41079
41080C...Threshold factors for c and b sea.
41081 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41082 XCHM=0.
41083 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41084 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41085 XCHM=XSEA*(1.-(SCH/SLL)**3)
41086 ENDIF
41087 XBOT=0.
41088 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41089 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41090 XBOT=XSEA*(1.-(SBT/SLL)**3)
41091 ENDIF
41092 ENDIF
41093
41094C...Add contribution of each valence flavour.
41095 XPGA(0)=XPGA(0)+FAC*XGLU
41096 XPGA(1)=XPGA(1)+FAC*XSEA
41097 XPGA(2)=XPGA(2)+FAC*XSEA
41098 XPGA(3)=XPGA(3)+FAC*XSEA
41099 XPGA(4)=XPGA(4)+FAC*XCHM
41100 XPGA(5)=XPGA(5)+FAC*XBOT
41101 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41102 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41103 110 CONTINUE
41104 DO 120 KFL=1,5
41105 XPGA(-KFL)=XPGA(KFL)
41106 VXPGA(-KFL)=VXPGA(KFL)
41107 120 CONTINUE
41108
41109 END
41110
41111C*********************************************************************
41112
41113*$ CREATE PHO_SASBEH.FOR
41114*COPY PHO_SASBEH
41115CDECK ID>, PHO_SASBEH
41116 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41117C...Purpose: to evaluate the Bethe-Heitler cross section for
41118C...heavy flavour production.
41119 SAVE
41120 DATA AEM2PI/0.0011614/
41121
41122C...Reset output.
41123 XPBH=0.
41124 SIGBH=0.
41125
41126C...Check kinematics limits.
41127 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41128 W2=Q2*(1.-X)/X-P2
41129 BETA2=1.-4.*PM2/W2
41130 IF(BETA2.LT.1E-10) RETURN
41131 BETA=SQRT(BETA2)
41132 RMQ=4.*PM2/Q2
41133
41134C...Simple case: P2 = 0.
41135 IF(P2.LT.1E-4) THEN
41136 IF(BETA.LT.0.99) THEN
41137 XBL=LOG((1.+BETA)/(1.-BETA))
41138 ELSE
41139 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41140 ENDIF
41141 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41142 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41143
41144C...Complicated case: P2 > 0, based on approximation of
41145C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41146 ELSE
41147 RPQ=1.-4.*X**2*P2/Q2
41148 IF(RPQ.GT.1E-10) THEN
41149 RPBE=SQRT(RPQ*BETA2)
41150 IF(RPBE.LT.0.99) THEN
41151 XBL=LOG((1.+RPBE)/(1.-RPBE))
41152 XBI=2.*RPBE/(1.-RPBE**2)
41153 ELSE
41154 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41155 XBL=LOG((1.+RPBE)**2/RPBESN)
41156 XBI=2.*RPBE/RPBESN
41157 ENDIF
41158 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41159 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41160 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41161 ENDIF
41162 ENDIF
41163
41164C...Multiply by charge-squared etc. to get parton distribution.
41165 CHSQ=1./9.
41166 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41167 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41168
41169 END
41170
41171C*********************************************************************
41172
41173*$ CREATE PHO_SASDIR.FOR
41174*COPY PHO_SASDIR
41175CDECK ID>, PHO_SASDIR
41176 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41177C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41178C...as needed in MSbar parametrizations.
41179 SAVE
41180 DIMENSION XPGA(-6:6)
41181 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41182
41183C...Reset output.
41184 DO 100 KFL=-6,6
41185 XPGA(KFL)=0.
41186 100 CONTINUE
41187
41188C...Evaluate common x-dependent expression.
41189 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41190 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41191
41192C...d, u, s part by simple charge factor.
41193 XPGA(1)=(1./9.)*CGAM
41194 XPGA(2)=(4./9.)*CGAM
41195 XPGA(3)=(1./9.)*CGAM
41196
41197C...Also fill for antiquarks.
41198 DO 110 KF=1,5
41199 XPGA(-KF)=XPGA(KF)
41200 110 CONTINUE
41201
41202 END
41203
41204*$ CREATE PHO_PHGAL.FOR
41205*COPY PHO_PHGAL
41206CDECK ID>, PHO_PHGAL
41207 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41208C***********************************************************************
41209C
41210C photon parton densities with built-in momentum sum rule and
41211C Regge-based low-x behaviour
41212C
41213C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41214C e-Print Archive: hep-ph/9711355
41215C
41216C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41217C
41218C***********************************************************************
41219 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41220 SAVE
41221
41222 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41223 DOUBLE PRECISION
41224 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41225 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41226
41227 DIMENSION NA(NARG)
41228
41229 DATA ZEROD/0.D0/
41230
41231C...100 x values; in (D-4,.77) log spaced (78 points)
41232C... in (.78,.995) lineary spaced (22 points)
41233 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41234 DATA XT/
41235 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41236 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41237 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41238 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41239 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41240 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41241 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41242 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41243 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41244 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41245 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41246 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41247 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41248 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41249 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41250 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41251 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41252
41253C...place for DATA blocks
41254 DATA (XPV(I,1,0),I=1,100)/
41255 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41256 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41257 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41258 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41259 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41260 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41261 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41262 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41263 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41264 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41265 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41266 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41267 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41268 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41269 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41270 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41271 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41272 DATA (XPV(I,1,1),I=1,100)/
41273 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41274 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41275 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41276 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41277 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41278 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41279 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41280 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41281 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41282 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41283 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41284 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41285 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41286 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41287 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41288 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41289 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41290 DATA (XPV(I,1,2),I=1,100)/
41291 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41292 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41293 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41294 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41295 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41296 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41297 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41298 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41299 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41300 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41301 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41302 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41303 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41304 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41305 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41306 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41307 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41308 DATA (XPV(I,1,3),I=1,100)/
41309 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41310 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41311 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41312 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41313 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41314 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41315 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41316 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41317 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41318 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41319 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41320 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41321 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41322 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41323 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41324 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41325 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41326 DATA (XPV(I,1,4),I=1,100)/
41327 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41328 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41329 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41330 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41331 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41332 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41333 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41334 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41335 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41336 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41337 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41338 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41339 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41340 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41341 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41342 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41343 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41344 DATA (XPV(I,2,0),I=1,100)/
41345 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41346 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41347 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41348 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41349 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41350 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41351 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41352 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41353 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41354 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41355 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41356 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41357 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41358 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41359 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41360 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41361 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41362 DATA (XPV(I,2,1),I=1,100)/
41363 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41364 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41365 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41366 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41367 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41368 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41369 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41370 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41371 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41372 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41373 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41374 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41375 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41376 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41377 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41378 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41379 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41380 DATA (XPV(I,2,2),I=1,100)/
41381 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41382 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41383 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41384 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41385 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41386 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41387 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41388 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41389 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41390 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41391 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41392 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41393 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41394 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41395 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41396 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41397 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41398 DATA (XPV(I,2,3),I=1,100)/
41399 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41400 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41401 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41402 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41403 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41404 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41405 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41406 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41407 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41408 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41409 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41410 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41411 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41412 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41413 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41414 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41415 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41416 DATA (XPV(I,2,4),I=1,100)/
41417 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41418 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41419 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41420 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41421 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41422 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41423 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41424 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41425 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41426 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41427 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41428 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41429 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41430 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41431 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41432 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41433 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41434 DATA (XPV(I,3,0),I=1,100)/
41435 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41436 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41437 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41438 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41439 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41440 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41441 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41442 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41443 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41444 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41445 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41446 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41447 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41448 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41449 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41450 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41451 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41452 DATA (XPV(I,3,1),I=1,100)/
41453 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41454 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41455 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41456 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41457 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41458 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41459 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41460 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41461 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41462 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41463 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41464 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41465 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41466 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41467 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41468 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41469 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41470 DATA (XPV(I,3,2),I=1,100)/
41471 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41472 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41473 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41474 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41475 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41476 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41477 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41478 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41479 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41480 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41481 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41482 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41483 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41484 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41485 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41486 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41487 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41488 DATA (XPV(I,3,3),I=1,100)/
41489 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41490 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41491 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41492 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41493 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41494 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41495 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41496 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41497 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41498 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41499 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41500 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41501 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41502 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41503 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41504 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41505 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41506 DATA (XPV(I,3,4),I=1,100)/
41507 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41508 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41509 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41510 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41511 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41512 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41513 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41514 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41515 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41516 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41517 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41518 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41519 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41520 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41521 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41522 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41523 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41524 DATA (XPV(I,4,0),I=1,100)/
41525 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41526 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41527 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41528 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41529 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41530 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41531 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41532 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41533 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41534 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41535 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41536 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41537 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41538 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41539 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41540 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41541 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41542 DATA (XPV(I,4,1),I=1,100)/
41543 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41544 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41545 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41546 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41547 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41548 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41549 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41550 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41551 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41552 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41553 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41554 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41555 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41556 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41557 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41558 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41559 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41560 DATA (XPV(I,4,2),I=1,100)/
41561 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41562 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41563 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41564 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41565 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41566 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41567 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41568 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41569 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41570 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41571 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41572 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41573 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41574 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41575 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41576 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41577 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41578 DATA (XPV(I,4,3),I=1,100)/
41579 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41580 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41581 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41582 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41583 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41584 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41585 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41586 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41587 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41588 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41589 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41590 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41591 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41592 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41593 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41594 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41595 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41596 DATA (XPV(I,4,4),I=1,100)/
41597 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41598 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41599 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41600 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41601 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41602 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41603 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41604 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41605 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41606 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41607 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41608 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41609 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41610 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41611 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41612 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41613 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41614 DATA (XPV(I,5,0),I=1,100)/
41615 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41616 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41617 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41618 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41619 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41620 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41621 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41622 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41623 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41624 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41625 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41626 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41627 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41628 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41629 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41630 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41631 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41632 DATA (XPV(I,5,1),I=1,100)/
41633 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41634 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41635 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41636 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41637 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41638 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41639 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41640 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41641 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41642 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41643 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41644 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41645 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41646 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41647 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41648 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41649 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41650 DATA (XPV(I,5,2),I=1,100)/
41651 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41652 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41653 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41654 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41655 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41656 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41657 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41658 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41659 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41660 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41661 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41662 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41663 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41664 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41665 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41666 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41667 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41668 DATA (XPV(I,5,3),I=1,100)/
41669 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41670 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41671 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41672 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41673 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41674 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41675 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41676 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41677 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41678 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41679 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41680 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41681 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41682 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41683 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41684 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41685 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41686 DATA (XPV(I,5,4),I=1,100)/
41687 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41688 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41689 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41690 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41691 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41692 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41693 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41694 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41695 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41696 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41697 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41698 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41699 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41700 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41701 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41702 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41703 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41704 DATA (XPV(I,6,0),I=1,100)/
41705 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41706 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41707 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41708 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41709 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41710 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41711 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41712 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41713 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41714 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41715 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41716 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41717 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41718 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41719 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41720 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41721 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41722 DATA (XPV(I,6,1),I=1,100)/
41723 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41724 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41725 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41726 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41727 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41728 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41729 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41730 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41731 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41732 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41733 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41734 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41735 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41736 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41737 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41738 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41739 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41740 DATA (XPV(I,6,2),I=1,100)/
41741 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41742 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41743 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41744 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41745 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41746 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41747 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41748 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41749 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41750 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41751 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41752 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41753 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41754 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41755 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41756 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41757 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41758 DATA (XPV(I,6,3),I=1,100)/
41759 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41760 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41761 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41762 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41763 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41764 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41765 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41766 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41767 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41768 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41769 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41770 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41771 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41772 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41773 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41774 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41775 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41776 DATA (XPV(I,6,4),I=1,100)/
41777 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41778 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41779 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41780 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41781 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41782 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41783 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41784 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41785 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41786 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41787 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41788 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41789 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41790 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41791 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41792 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41793 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41794 DATA (XPV(I,7,0),I=1,100)/
41795 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41796 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41797 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41798 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41799 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41800 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41801 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41802 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41803 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41804 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41805 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41806 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41807 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41808 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41809 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41810 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41811 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41812 DATA (XPV(I,7,1),I=1,100)/
41813 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41814 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41815 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41816 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41817 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41818 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41819 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41820 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41821 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41822 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41823 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41824 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41825 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41826 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41827 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41828 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41829 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41830 DATA (XPV(I,7,2),I=1,100)/
41831 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41832 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41833 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41834 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41835 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41836 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41837 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41838 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41839 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41840 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41841 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41842 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41843 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41844 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41845 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41846 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41847 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41848 DATA (XPV(I,7,3),I=1,100)/
41849 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41850 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41851 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41852 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41853 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41854 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41855 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41856 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41857 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41858 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41859 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41860 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41861 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41862 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41863 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41864 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41865 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41866 DATA (XPV(I,7,4),I=1,100)/
41867 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41868 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41869 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41870 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41871 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41872 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41873 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41874 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41875 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41876 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41877 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41878 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41879 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41880 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41881 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41882 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41883 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41884
41885C..fetching pdfs
41886 DO 5 IP=-6,6
41887 XPDF(IP)=ZEROD
41888 5 CONTINUE
41889 DO 2 I=1,IX
41890 ENT(I)=LOG10(XT(I))
41891 2 CONTINUE
41892 NA(1)=IX
41893 NA(2)=IQ
41894 DO 3 I=1,IQ
41895 ENT(IX+I)=LOG10(Q2T(I))
41896 3 CONTINUE
41897 ARG(1)=LOG10(X)
41898 ARG(2)=LOG10(Q2)
41899C..various flavours (u-->2,d-->1)
41900 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41901 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41902 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41903 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41904 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41905 DO 21 JF=1,4
41906 XPDF(-JF)=XPDF(JF)
41907 21 CONTINUE
41908
41909 END
41910
41911*$ CREATE PHO_DBFINT.FOR
41912*COPY PHO_DBFINT
41913CDECK ID>, PHO_DBFINT
41914 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41915C***********************************************************************
41916C
41917C routine based on CERN library E104
41918C
41919C multi-dimensional interpolation routine, needed for PHOJET
41920C internal cross section tables and several PDF sets (GRV98 and AGL)
41921C
41922C changed to avoid recursive function calls (R.Engel, 09/98)
41923C
41924C***********************************************************************
41925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41926 SAVE
41927
41928 INTEGER NA(NARG), INDEX(32)
41929 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41930
41931 DATA ZEROD/0.D0/
41932 DATA ONED/1.D0/
41933
41934 DBFINT = ZEROD
41935 PHO_DBFINT = ZEROD
41936 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41937
41938 LMAX = 0
41939 ISTEP = 1
41940 KNOTS = 1
41941 INDEX(1) = 1
41942 WEIGHT(1) = ONED
41943 DO 100 N = 1, NARG
41944 X = ARG(N)
41945 NDIM = NA(N)
41946 LOCA = LMAX
41947 LMIN = LMAX + 1
41948 LMAX = LMAX + NDIM
41949 IF(NDIM .GT. 2) GOTO 10
41950 IF(NDIM .EQ. 1) GOTO 100
41951 H = X - ENT(LMIN)
41952 IF(H .EQ. ZEROD) GOTO 90
41953 ISHIFT = ISTEP
41954 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41955 ISHIFT = 0
41956 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41957 GOTO 30
41958 10 LOCB = LMAX + 1
41959 11 LOCC = (LOCA+LOCB) / 2
41960 IF(X-ENT(LOCC)) 12, 20, 13
41961 12 LOCB = LOCC
41962 GOTO 14
41963 13 LOCA = LOCC
41964 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41965 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41966 ISHIFT = (LOCA - LMIN) * ISTEP
41967 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41968 GOTO 30
41969 20 ISHIFT = (LOCC - LMIN) * ISTEP
41970 21 DO 22 K = 1, KNOTS
41971 INDEX(K) = INDEX(K) + ISHIFT
41972 22 CONTINUE
41973 GOTO 90
41974 30 DO 31 K = 1, KNOTS
41975 INDEX(K) = INDEX(K) + ISHIFT
41976 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41977 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41978 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41979 31 CONTINUE
41980 KNOTS = 2*KNOTS
41981 90 ISTEP = ISTEP * NDIM
41982 100 CONTINUE
41983 DO 200 K = 1, KNOTS
41984 I = INDEX(K)
41985 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
41986 200 CONTINUE
41987
41988 PHO_DBFINT = DBFINT
41989
41990 END
41991
41992*$ CREATE PHVAL.FOR
41993*COPY PHVAL
41994CDECK ID>, PHVAL
41995 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41996C**********************************************************************
41997C
41998C dummy subroutine, remove to link PHOLIB
41999C
42000C**********************************************************************
42001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42002 DIMENSION PD(-6:6)
42003 END