--- /dev/null
+*$ CREATE DT_INIT.FOR
+*COPY DT_INIT
+*
+* +-------------------------------------------------------------+
+* | |
+* | |
+* | DPMJET 3.0 |
+* | |
+* | |
+* | S. Roesler+), R. Engel#), J. Ranft*) |
+* | |
+* | +) CERN, SC-RP |
+* | CH-1211 Geneva 23, Switzerland |
+* | Email: Stefan.Roesler@cern.ch |
+* | |
+* | #) Institut fuer Kernphysik |
+* | Forschungszentrum Karlsruhe |
+* | D-76021 Karlsruhe, Germany |
+* | |
+* | *) University of Siegen, Dept. of Physics |
+* | D-57068 Siegen, Germany |
+* | |
+* | |
+* | http://home.cern.ch/sroesler/dpmjet3.html |
+* | |
+* | |
+* | Monte Carlo models used for event generation: |
+* | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
+* | |
+* +-------------------------------------------------------------+
+*
+*
+*===init===============================================================*
+*
+ SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+ & IDP,IGLAU)
+
+************************************************************************
+* Initialization of event generation *
+* This version dated 7.4.98 is written by S. Roesler. *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* names of hadrons used in input-cards
+ CHARACTER*8 BTYPE
+ COMMON /DTPAIN/ BTYPE(30)
+
+* INCLUDE '(DIMPAR)'
+* DIMPAR taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(PAREVT)'
+* PAREVT taken from FLUKA
+ PARAMETER ( FRDIFF = 0.2D+00 )
+ PARAMETER ( ETHSEA = 1.0D+00 )
+*
+ LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+ & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
+ & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
+ & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
+ COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
+ & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+ & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+ & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
+ & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
+ & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
+
+* INCLUDE '(EVAFLG)'
+* EVAFLG taken from FLUKA
+ LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
+ & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
+ & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
+ & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
+ COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
+ & FDSCST,
+ & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
+ & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
+ & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
+ & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
+ & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
+ & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
+ & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
+
+* INCLUDE '(FRBKCM)'
+* FRBKCM taken from FLUKA
+* Maximum number of fragments to be emitted:
+ PARAMETER ( MXFFBK = 6 )
+ PARAMETER ( MXZFBK = 10 )
+ PARAMETER ( MXNFBK = 12 )
+ PARAMETER ( MXAFBK = 16 )
+ PARAMETER ( MXASST = 25 )
+ PARAMETER ( NXAFBK = MXAFBK + 1 )
+ PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
+ PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
+ PARAMETER ( MXPSST = 700 )
+* Maximum number of pre-computed break-up combinations
+ PARAMETER ( MXPPFB = 42500 )
+* Maximum number of break-up combinations, including special
+* run-time ones:
+ PARAMETER ( MXPSFB = 43000 )
+* Base for J multiplicity encoding:
+ PARAMETER ( IBFRBK = 73 )
+* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
+* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
+* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
+* --> Ibfrbk^(Jpwfbx+1) < 2100000000
+ PARAMETER ( JPWFBX = 4 )
+ LOGICAL LFRMBK, LNCMSS
+ COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
+ & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
+ & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
+ & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
+ & IFRBKN (MXPSST), IFRBKZ (MXPSST),
+ & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
+ & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
+ & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
+ & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
+ & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* interface HADRIN-DPM
+ COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* parameters for hA-diffraction
+ COMMON /DTDIHA/ DIBETA,DIALPH
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* kinematical cuts for lepton-nucleus interactions
+ COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+ & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+* cuts for variable energy runs
+ COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+
+* flags for activated histograms
+ COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+* LEPTO
+**LUND single / double precision
+ REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
+ COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
+ & TMPX,TMPY,TMPW2,TMPQ2,TMPU
+
+* LEPTO
+ REAL RPPN
+ COMMON /LEPTOI/ RPPN,LEPIN,INTER
+
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ INTEGER PYCOMP
+
+C DIMENSION XPARA(5)
+ DIMENSION XDUMB(40),IPRANG(5)
+
+ PARAMETER (MXCARD=58)
+ CHARACTER*78 CLINE,CTITLE
+ CHARACTER*60 CWHAT
+ CHARACTER*8 BLANK,SDUM
+ CHARACTER*10 CODE,CODEWD
+ CHARACTER*72 HEADER
+ LOGICAL LSTART,LEINP,LXSTAB
+ DIMENSION WHAT(6),CODE(MXCARD)
+ DATA CODE/
+ & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
+ & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
+ & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
+ & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
+ & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
+ & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
+ & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
+ & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
+ & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
+ & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
+ & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
+ & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
+ & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
+ & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
+ & 'START ','STOP '/
+ DATA BLANK /' '/
+
+ DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
+ DATA CMEOLD /0.0D0/
+
+*---------------------------------------------------------------------
+* at the first call of INIT: initialize event generation
+ EPNSAV = EPN
+ IF (LSTART) THEN
+ CALL DT_TITLE
+* initialization and test of the random number generator
+ IF (ITRSPT.NE.1) THEN
+
+ IJKLIN = -1
+ INSEED = 1
+ ISEED1 = 0
+ ISEED2 = 0
+ CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
+
+ ENDIF
+* initialization of BAMJET, DECAY and HADRIN
+ CALL DT_DDATAR
+ CALL DT_DHADDE
+ CALL DT_DCHANT
+ CALL DT_DCHANH
+* set default values for input variables
+ CALL DT_DEFAUL(EPN,PPN)
+ IGLAU = 0
+ IXSQEL = 0
+* flag for collision energy input
+ LEINP = .FALSE.
+ LSTART = .FALSE.
+ ENDIF
+
+*---------------------------------------------------------------------
+ 10 CONTINUE
+
+* bypass reading input cards (e.g. for use with Fluka)
+* in this case Epn is expected to carry the beam momentum
+ IF (NCASES.EQ.-1) THEN
+ IP = NPMASS
+ IPZ = NPCHAR
+ PPN = EPNSAV
+ EPN = ZERO
+ CMENER = ZERO
+ LEINP = .TRUE.
+ MKCRON = 0
+ WHAT(1) = 1
+ WHAT(2) = 0
+ CODEWD = 'START '
+ GOTO 900
+ ENDIF
+
+* read control card from input-unit LINP
+ READ(LINP,'(A78)',END=9999) CLINE
+ IF (CLINE(1:1).EQ.'*') THEN
+* comment-line
+ WRITE(LOUT,'(A78)') CLINE
+ GOTO 10
+ ENDIF
+C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
+C1000 FORMAT(A10,6E10.0,A8)
+ DO 1008 I=1,6
+ WHAT(I) = ZERO
+ 1008 CONTINUE
+ READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
+ 1006 FORMAT(A10,A60,A8)
+ READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
+ 1007 CONTINUE
+ WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
+ 1001 FORMAT(A10,6G10.3,A8)
+
+ 900 CONTINUE
+
+* check for valid control card and get card index
+ ICW = 0
+ DO 11 I=1,MXCARD
+ IF (CODEWD.EQ.CODE(I)) ICW = I
+ 11 CONTINUE
+ IF (ICW.EQ.0) THEN
+ WRITE(LOUT,1002) CODEWD
+ 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
+ GOTO 10
+ ENDIF
+
+ GOTO(
+*------------------------------------------------------------
+* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
+ & 100 , 110 , 120 , 130 , 140 ,
+*
+*------------------------------------------------------------
+* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
+ & 150 , 160 , 170 , 180 , 190 ,
+*
+*------------------------------------------------------------
+* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
+ & 200 , 210 , 220 , 230 , 240 ,
+*
+*------------------------------------------------------------
+* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
+ & 250 , 260 , 270 , 280 , 290 ,
+*
+*------------------------------------------------------------
+* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
+ & 300 , 310 , 320 , 330 , 340 ,
+*
+*------------------------------------------------------------
+* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
+ & 350 , 360 , 370 , 380 , 390 ,
+*
+*------------------------------------------------------------
+* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
+ & 400 , 410 , 420 , 430 , 440 ,
+*
+*------------------------------------------------------------
+* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
+ & 450 , 451 , 452 , 460 , 470 ,
+*
+*------------------------------------------------------------
+* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
+ & 480 , 490 , 500 , 510 , 520 ,
+*
+*------------------------------------------------------------
+* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
+ & 530 , 540 , 550 , 560 , 565 ,
+*
+*------------------------------------------------------------
+* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
+ & 570 , 580 , 590 ,
+*
+*------------------------------------------------------------
+* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
+ & 600 , 610 , 620 , 630 , 640 ) , ICW
+*
+*------------------------------------------------------------
+
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = TITLE *
+* *
+* what (1..6), sdum no meaning *
+* *
+* Note: The control-card following this must consist of *
+* a string of characters usually giving the title of *
+* the run. *
+* *
+*********************************************************************
+
+ 100 CONTINUE
+ READ(LINP,'(A78)') CTITLE
+ WRITE(LOUT,'(//,5X,A78,//)') CTITLE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = PROJPAR *
+* *
+* what (1) = mass number of projectile nucleus default: 1 *
+* what (2) = charge of projectile nucleus default: 1 *
+* what (3..6) no meaning *
+* sdum projectile particle code word *
+* *
+* Note: If sdum is defined what (1..2) have no meaning. *
+* *
+*********************************************************************
+
+ 110 CONTINUE
+ IF (SDUM.EQ.BLANK) THEN
+ IP = INT(WHAT(1))
+ IPZ = INT(WHAT(2))
+ IJPROJ = 1
+ IBPROJ = 1
+ ELSE
+ IJPROJ = 0
+ DO 111 II=1,30
+ IF (SDUM.EQ.BTYPE(II)) THEN
+ IP = 1
+ IPZ = 1
+ IF (II.EQ.26) THEN
+ IJPROJ = 135
+ ELSEIF (II.EQ.27) THEN
+ IJPROJ = 136
+ ELSEIF (II.EQ.28) THEN
+ IJPROJ = 133
+ ELSEIF (II.EQ.29) THEN
+ IJPROJ = 134
+ ELSE
+ IJPROJ = II
+ ENDIF
+ IBPROJ = IIBAR(IJPROJ)
+* photon
+ IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
+* lepton
+ IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
+ & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
+ & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
+ ENDIF
+ 111 CONTINUE
+ IF (IJPROJ.EQ.0) THEN
+ WRITE(LOUT,1110)
+ 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
+ GOTO 9999
+ ENDIF
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = TARPAR *
+* *
+* what (1) = mass number of target nucleus default: 1 *
+* what (2) = charge of target nucleus default: 1 *
+* what (3..6) no meaning *
+* sdum target particle code word *
+* *
+* Note: If sdum is defined what (1..2) have no meaning. *
+* *
+*********************************************************************
+
+ 120 CONTINUE
+ IF (SDUM.EQ.BLANK) THEN
+ IT = INT(WHAT(1))
+ ITZ = INT(WHAT(2))
+ IJTARG = 1
+ IBTARG = 1
+ ELSE
+ IJTARG = 0
+ DO 121 II=1,30
+ IF (SDUM.EQ.BTYPE(II)) THEN
+ IT = 1
+ ITZ = 1
+ IJTARG = II
+ IBTARG = IIBAR(IJTARG)
+ ENDIF
+ 121 CONTINUE
+ IF (IJTARG.EQ.0) THEN
+ WRITE(LOUT,1120)
+ 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
+ GOTO 9999
+ ENDIF
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = ENERGY *
+* *
+* what (1) = energy (GeV) of projectile in Lab. *
+* if what(1) < 0: |what(1)| = kinetic energy *
+* default: 200 GeV *
+* if |what(2)| > 0: min. energy for variable *
+* energy runs *
+* what (2) = max. energy for variable energy runs *
+* if what(2) < 0: |what(2)| = kinetic energy *
+* *
+*********************************************************************
+
+ 130 CONTINUE
+ EPN = WHAT(1)
+ PPN = ZERO
+ CMENER = ZERO
+ IF ((ABS(WHAT(2)).GT.ZERO).AND.
+ & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
+ VARELO = WHAT(1)
+ VAREHI = WHAT(2)
+ EPN = VAREHI
+ ENDIF
+ LEINP = .TRUE.
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = MOMENTUM *
+* *
+* what (1) = momentum (GeV/c) of projectile in Lab. *
+* default: 200 GeV/c *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 140 CONTINUE
+ EPN = ZERO
+ PPN = WHAT(1)
+ CMENER = ZERO
+ LEINP = .TRUE.
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = CMENERGY *
+* *
+* what (1) = energy in nucleon-nucleon cms. *
+* default: none *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 150 CONTINUE
+ EPN = ZERO
+ PPN = ZERO
+ CMENER = WHAT(1)
+ LEINP = .TRUE.
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = EMULSION *
+* *
+* definition of nuclear emulsions *
+* *
+* what(1) mass number of emulsion component *
+* what(2) charge of emulsion component *
+* what(3) fraction of events in which a scattering on a *
+* nucleus of this properties is performed *
+* what(4,5,6) as what(1,2,3) but for another component *
+* default: no emulsion *
+* sdum no meaning *
+* *
+* Note: If this input-card is once used with valid parameters *
+* TARPAR is obsolete. *
+* Not the absolute values of the fractions are important *
+* but only the ratios of fractions of different comp. *
+* This control card can be repeatedly used to define *
+* emulsions consisting of up to 10 elements. *
+* *
+*********************************************************************
+
+ 160 CONTINUE
+ IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
+ & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
+ NCOMPO = NCOMPO+1
+ IF (NCOMPO.GT.NCOMPX) THEN
+ WRITE(LOUT,1600)
+ STOP
+ ENDIF
+ IEMUMA(NCOMPO) = INT(WHAT(1))
+ IEMUCH(NCOMPO) = INT(WHAT(2))
+ EMUFRA(NCOMPO) = WHAT(3)
+ IEMUL = 1
+C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
+ ENDIF
+ IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
+ & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
+ NCOMPO = NCOMPO+1
+ IF (NCOMPO.GT.NCOMPX) THEN
+ WRITE(LOUT,1001)
+ STOP
+ ENDIF
+ IEMUMA(NCOMPO) = INT(WHAT(4))
+ IEMUCH(NCOMPO) = INT(WHAT(5))
+ EMUFRA(NCOMPO) = WHAT(6)
+C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
+ ENDIF
+ 1600 FORMAT(1X,'too many emulsion components - program stopped')
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = FERMI *
+* *
+* what (1) = -1 Fermi-motion of nucleons not treated *
+* default: 1 *
+* what (2) = scale factor for Fermi-momentum *
+* default: 0.75 *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 170 CONTINUE
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ LFERMI = .FALSE.
+ ELSE
+ LFERMI = .TRUE.
+ ENDIF
+ XMOD = WHAT(2)
+ IF (XMOD.GE.ZERO) FERMOD = XMOD
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = TAUFOR *
+* *
+* formation time supressed intranuclear cascade *
+* *
+* what (1) formation time (in fm/c) *
+* note: what(1)=10. corresponds roughly to an *
+* average formation time of 1 fm/c *
+* default: 5. fm/c *
+* what (2) number of generations followed *
+* default: 25 *
+* what (3) = 1. p_t-dependent formation zone *
+* = 2. constant formation zone *
+* default: 1 *
+* what (4) modus of selection of nucleus where the *
+* cascade if followed first *
+* = 1. proj./target-nucleus with probab. 1/2 *
+* = 2. nucleus with highest mass *
+* = 3. proj. nucleus if particle is moving in pos. z *
+* targ. nucleus if particle is moving in neg. z *
+* default: 1 *
+* what (5..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 180 CONTINUE
+ TAUFOR = WHAT(1)
+ KTAUGE = INT(WHAT(2))
+ INCMOD = 1
+ IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
+ & ITAUVE = INT(WHAT(3))
+ IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
+ & INCMOD = INT(WHAT(4))
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = PAULI *
+* *
+* what (1) = -1 Pauli's principle for secondary *
+* interactions not treated *
+* default: 1 *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 190 CONTINUE
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ LPAULI = .FALSE.
+ ELSE
+ LPAULI = .TRUE.
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = COULOMB *
+* *
+* what (1) = -1. Coulomb-energy treatment switched off *
+* default: 1 *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 200 CONTINUE
+ ICOUL = 1
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ ICOUL = 0
+ ELSE
+ ICOUL = 1
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = HADRIN *
+* *
+* HADRIN module *
+* *
+* what (1) = 0. elastic/inelastic interactions with probab. *
+* as defined by cross-sections *
+* = 1. inelastic interactions forced *
+* = 2. elastic interactions forced *
+* default: 1 *
+* what (2) upper threshold in total energy (GeV) below *
+* which interactions are sampled by HADRIN *
+* default: 5. GeV *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 210 CONTINUE
+ IWHAT = INT(WHAT(1))
+ IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
+ IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = EVAP *
+* *
+* evaporation module *
+* *
+* what (1) =< -1 ==> evaporation is switched off *
+* >= 1 ==> evaporation is performed *
+* *
+* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
+* (i1, i2, i3, i4 >= 0 ) *
+* *
+* i1 is the flag for selecting the T=0 level density option used *
+* = 1: standard EVAP level densities with Cook pairing *
+* energies *
+* = 2: Z,N-dependent Gilbert & Cameron level densities *
+* (default) *
+* = 3: Julich A-dependent level densities *
+* = 4: Z,N-dependent Brancazio & Cameron level densities *
+* *
+* i2 >= 1: high energy fission activated *
+* (default high energy fission activated) *
+* *
+* i3 = 0: No energy dependence for level densities *
+* = 1: Standard Ignyatuk (1975, 1st) energy dependence *
+* for level densities (default) *
+* = 2: Standard Ignyatuk (1975, 1st) energy dependence *
+* for level densities with NOT used set of parameters *
+* = 3: Standard Ignyatuk (1975, 1st) energy dependence *
+* for level densities with NOT used set of parameters *
+* = 4: Second Ignyatuk (1975, 2nd) energy dependence *
+* for level densities *
+* = 5: Second Ignyatuk (1975, 2nd) energy dependence *
+* for level densities with fit 1 Iljinov & Mebel set of *
+* parameters *
+* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
+* for level densities with fit 2 Iljinov & Mebel set of *
+* parameters *
+* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
+* for level densities with fit 3 Iljinov & Mebel set of *
+* parameters *
+* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
+* for level densities with fit 4 Iljinov & Mebel set of *
+* parameters *
+* *
+* i4 >= 1: Original Gilbert and Cameron pairing energies used *
+* (default Cook's modified pairing energies) *
+* *
+* what (2) = ig + 10 * if (ig and if must have the same sign) *
+* *
+* ig =< -1 ==> deexcitation gammas are not produced *
+* (if the evaporation step is not performed *
+* they are never produced) *
+* if =< -1 ==> Fermi Break Up is not invoked *
+* (if the evaporation step is not performed *
+* it is never invoked) *
+* The default is: deexcitation gamma produced and Fermi break up *
+* activated for the new preequilibrium, not *
+* activated otherwise. *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 220 CONTINUE
+ IF (WHAT(1).LE.-1.0D0) THEN
+ LEVPRT = .FALSE.
+ LDEEXG = .FALSE.
+ LHEAVY = .FALSE.
+ GOTO 10
+ ENDIF
+ WHTSAV = WHAT (1)
+ IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
+ LLVMOD = .FALSE.
+ JLVHLP = NINT (WHAT (1)) / 10000
+ WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
+ END IF
+ IF ( NINT (WHAT (1)) .GE. 100 ) THEN
+ JLVMOD = NINT (WHAT (1)) / 100
+ WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
+ END IF
+ IF ( NINT (WHAT (1)) .GE. 10 ) THEN
+
+ IEVFSS = 1
+
+ JLVHLP = NINT (WHAT (1)) / 10
+ WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
+ ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
+
+ IEVFSS = 0
+
+ END IF
+ IF ( NINT (WHAT (1)) .GE. 0 ) THEN
+ LEVPRT = .TRUE.
+ ILVMOD = NINT (WHAT(1))
+ IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
+ LFRMBK = .TRUE.
+ JLVHLP = NINT (WHAT (2)) / 10
+ WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
+ ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
+ LFRMBK = .FALSE.
+ END IF
+ IF ( NINT (WHAT (2)) .GE. 0 ) THEN
+ LDEEXG = .TRUE.
+ ELSE
+ LDEEXG = .FALSE.
+ END IF
+**sr heavies are always put to /FKFHVY/
+C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
+C LHEAVY = .TRUE.
+C ELSE
+C LHEAVY = .FALSE.
+C END IF
+ LHEAVY = .TRUE.
+ ELSE
+ LEVPRT = .FALSE.
+ LDEEXG = .FALSE.
+ LHEAVY = .FALSE.
+ END IF
+
+ LOLDEV = .FALSE.
+
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = EMCCHECK *
+* *
+* extended energy-momentum / quantum-number conservation check *
+* *
+* what (1) = -1 extended check not performed *
+* default: 1. *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 230 CONTINUE
+ IF (WHAT(1).EQ.-1) THEN
+ LEMCCK = .FALSE.
+ ELSE
+ LEMCCK = .TRUE.
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = MODEL *
+* *
+* Model to be used to treat nucleon-nucleon interactions *
+* *
+* sdum = DTUNUC two-chain model *
+* = PHOJET multiple chains including minijets *
+* = LEPTO DIS *
+* = QNEUTRIN quasi-elastic neutrino scattering *
+* default: PHOJET *
+* *
+* if sdum = LEPTO: *
+* what (1) (variable INTER) *
+* = 1 gamma exchange *
+* = 2 W+- exchange *
+* = 3 Z0 exchange *
+* = 4 gamma/Z0 exchange *
+* *
+* if sdum = QNEUTRIN: *
+* what (1) = 0 elastic scattering on nucleon and *
+* tau does not decay (default) *
+* = 1 decay of tau into mu.. *
+* = 2 decay of tau into e.. *
+* = 10 CC events on p and n *
+* = 11 NC events on p and n *
+* *
+* what (2..6) no meaning *
+* *
+*********************************************************************
+
+ 240 CONTINUE
+ IF (SDUM.EQ.CMODEL(1)) THEN
+ MCGENE = 1
+ ELSEIF (SDUM.EQ.CMODEL(2)) THEN
+ MCGENE = 2
+ ELSEIF (SDUM.EQ.CMODEL(3)) THEN
+ MCGENE = 3
+ IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
+ & INTER = INT(WHAT(1))
+ ELSEIF (SDUM.EQ.CMODEL(4)) THEN
+ MCGENE = 4
+ IWHAT = INT(WHAT(1))
+ IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
+ & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
+ & NEUDEC = IWHAT
+ ELSE
+ STOP ' Unknown model !'
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = PHOINPUT *
+* *
+* Start of input-section for PHOJET-specific input-cards *
+* Note: This section will not be finished before giving *
+* ENDINPUT-card *
+* what (1..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 250 CONTINUE
+ IF (LPHOIN) THEN
+
+ CALL PHO_INIT(LINP,LOUT,IREJ1)
+
+ IF (IREJ1.NE.0) THEN
+ WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
+ STOP
+ ENDIF
+ LPHOIN = .FALSE.
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = GLAUBERI *
+* *
+* Pre-initialization of impact parameter selection *
+* *
+* what (1..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 260 CONTINUE
+ IF (IFIRST.NE.99) THEN
+ CALL DT_RNDMST(12,34,56,78)
+ CALL DT_RNDMTE(1)
+ OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
+C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
+ IFIRST = 99
+ ENDIF
+
+ IPPN = 8
+ PLOW = 10.0D0
+C IPPN = 1
+C PLOW = 100.0D0
+ PHI = 1.0D5
+ APLOW = LOG10(PLOW)
+ APHI = LOG10(PHI)
+ ADP = (APHI-APLOW)/DBLE(IPPN)
+
+ IPLOW = 1
+ IDIP = 1
+ IIP = 5
+C IPLOW = 1
+C IDIP = 1
+C IIP = 1
+ IPRANG(1) = 1
+ IPRANG(2) = 2
+ IPRANG(3) = 5
+ IPRANG(4) = 10
+ IPRANG(5) = 20
+
+ ITLOW = 30
+ IDIT = 3
+ IIT = 60
+C IDIT = 10
+C IIT = 21
+
+ DO 473 NCIT=1,IIT
+ IT = ITLOW+(NCIT-1)*IDIT
+C IPHI = IT
+C IDIP = 10
+C IIP = (IPHI-IPLOW)/IDIP
+C IF (IIP.EQ.0) IIP = 1
+C IF (IT.EQ.IPLOW) IIP = 0
+
+ DO 472 NCIP=1,IIP
+ IP = IPRANG(NCIP)
+CC IF (NCIP.LE.IIP) THEN
+C IP = IPLOW+(NCIP-1)*IDIP
+CC ELSE
+CC IP = IT
+CC ENDIF
+ IF (IP.GT.IT) GOTO 472
+
+ DO 471 NCP=1,IPPN+1
+ APPN = APLOW+DBLE(NCP-1)*ADP
+ PPN = 10**APPN
+
+ OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
+ WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
+ CLOSE(12)
+
+ XLIM1 = 0.0D0
+ XLIM2 = 50.0D0
+ XLIM3 = ZERO
+ IBIN = 50
+ CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
+ CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
+
+ NEVFIT = 5
+C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
+C NEVFIT = 5
+C ELSE
+C NEVFIT = 10
+C ENDIF
+ SIGAV = 0.0D0
+
+ DO 478 I=1,NEVFIT
+ CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
+ SIGAV = SIGAV+XSPRO(1,1,1)
+ DO 479 J=1,50
+ XC = DBLE(J)
+ CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
+ 479 CONTINUE
+ 478 CONTINUE
+
+ CALL DT_EVTHIS(IDUM)
+ HEADER = ' BSITE'
+C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
+
+C CALL GENFIT(XPARA)
+C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
+C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
+
+ 471 CONTINUE
+
+ 472 CONTINUE
+
+ 473 CONTINUE
+
+ STOP
+
+*********************************************************************
+* *
+* control card: codewd = FLUCTUAT *
+* *
+* Treatment of cross section fluctuations *
+* *
+* what (1) = 1 treat cross section fluctuations *
+* default: 0. *
+* what (1..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 270 CONTINUE
+ IFLUCT = 0
+ IF (WHAT(1).EQ.ONE) THEN
+ IFLUCT = 1
+ CALL DT_FLUINI
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = CENTRAL *
+* *
+* what (1) = 1. central production forced default: 0 *
+* if what (1) < 0 and > -100 *
+* what (2) = min. impact parameter default: 0 *
+* what (3) = max. impact parameter default: b_max *
+* if what (1) < -99 *
+* what (2) = fraction of cross section default: 1 *
+* if what (1) = -1 : evaporation/fzc suppressed *
+* if what (1) < -1 : evaporation/fzc allowed *
+* *
+* what (4..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 280 CONTINUE
+ ICENTR = INT(WHAT(1))
+ IF (ICENTR.LT.0) THEN
+ IF (ICENTR.GT.-100) THEN
+ BIMIN = WHAT(2)
+ BIMAX = WHAT(3)
+ ELSE
+ XSFRAC = WHAT(2)
+ ENDIF
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = RECOMBIN *
+* *
+* Chain recombination *
+* (recombine S-S and V-V chains to V-S chains) *
+* *
+* what (1) = -1. recombination switched off default: 1 *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 290 CONTINUE
+ IRECOM = 1
+ IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = COMBIJET *
+* *
+* chain fusion (2 q-aq --> qq-aqaq) *
+* *
+* what (1) = 1 fusion treated *
+* default: 0. *
+* what (2) minimum number of uncombined chains from *
+* single projectile or target nucleons *
+* default: 0. *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 300 CONTINUE
+ LCO2CR = .FALSE.
+ IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
+ IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = XCUTS *
+* *
+* thresholds for x-sampling *
+* *
+* what (1) defines lower threshold for val.-q x-value (CVQ) *
+* default: 1. *
+* what (2) defines lower threshold for val.-qq x-value (CDQ) *
+* default: 2. *
+* what (3) defines lower threshold for sea-q x-value (CSEA) *
+* default: 0.2 *
+* what (4) sea-q x-values in S-S chains (SSMIMA) *
+* default: 0.14 *
+* what (5) not used *
+* default: 2. *
+* what (6), sdum no meaning *
+* *
+* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
+* *
+*********************************************************************
+
+ 310 CONTINUE
+ IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
+ IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
+ IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
+ IF (WHAT(4).GE.ZERO) THEN
+ SSMIMA = WHAT(4)
+ SSMIMQ = SSMIMA**2
+ ENDIF
+ IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = INTPT *
+* *
+* what (1) = -1 intrinsic transverse momenta of partons *
+* not treated default: 1 *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 320 CONTINUE
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ LINTPT = .FALSE.
+ ELSE
+ LINTPT = .TRUE.
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = CRONINPT *
+* *
+* Cronin effect (multiple scattering of partons at chain ends) *
+* *
+* what (1) = -1 Cronin effect not treated default: 1 *
+* what (2) = 0 scattering parameter default: 0.64 *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 330 CONTINUE
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ MKCRON = 0
+ ELSE
+ MKCRON = 1
+ ENDIF
+ CRONCO = WHAT(2)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = SEADISTR *
+* *
+* what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
+* what (2) (UNON) default: 2. *
+* what (3) (UNOM) default: 1.5 *
+* what (4) (UNOSEA) default: 5. *
+* qdis(x) prop. (1-x)**what (1) etc. *
+* what (5..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 340 CONTINUE
+ XSEACO = WHAT(1)
+ XSEACU = 1.05D0-XSEACO
+ UNON = WHAT(2)
+ IF (UNON.LT.0.1D0) UNON = 2.0D0
+ UNOM = WHAT(3)
+ IF (UNOM.LT.0.1D0) UNOM = 1.5D0
+ UNOSEA = WHAT(4)
+ IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = SEASU3 *
+* *
+* Treatment of strange-quarks at chain ends *
+* *
+* what (1) (SEASQ) strange-quark supression factor *
+* iflav = 1.+rndm*(2.+SEASQ) *
+* default: 1. *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 350 CONTINUE
+ SEASQ = WHAT(1)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = DIQUARKS *
+* *
+* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
+* default: 1. *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 360 CONTINUE
+ IF (WHAT(1).EQ.-1.0D0) THEN
+ LSEADI = .FALSE.
+ ELSE
+ LSEADI = .TRUE.
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = RESONANC *
+* *
+* treatment of low mass chains *
+* *
+* what (1) = -1 low chain masses are not corrected for resonance *
+* masses (obsolete for BAMJET-fragmentation) *
+* default: 1. *
+* what (2) = -1 massless partons default: 1. (massive) *
+* default: 1. (massive) *
+* what (3) = -1 chain-system containing chain of too small *
+* mass is rejected (note: this does not fully *
+* apply to S-S chains) default: 0. *
+* what (4..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 370 CONTINUE
+ IRESCO = 1
+ IMSHL = 1
+ IRESRJ = 0
+ IF (WHAT(1).EQ.-ONE) IRESCO = 0
+ IF (WHAT(2).EQ.-ONE) IMSHL = 0
+ IF (WHAT(3).EQ.-ONE) IRESRJ = 1
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = DIFFRACT *
+* *
+* Treatment of diffractive events *
+* *
+* what (1) = (ISINGD) 0 no single diffraction *
+* 1 single diffraction included *
+* +-2 single diffractive events only *
+* +-3 projectile single diffraction only *
+* +-4 target single diffraction only *
+* -5 double pomeron exchange only *
+* (neg. sign applies to PHOJET events) *
+* default: 0. *
+* *
+* what (2) = (IDOUBD) 0 no double diffraction *
+* 1 double diffraction included *
+* 2 double diffractive events only *
+* default: 0. *
+* what (3) = 1 projectile diffraction treated (2-channel form.) *
+* default: 0. *
+* what (4) = alpha-parameter in projectile diffraction *
+* default: 0. *
+* what (5..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 380 CONTINUE
+ IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
+ IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
+ IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
+ WRITE(LOUT,1380)
+ 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
+ & 11X,'IDOUBD is reset to zero')
+ IDOUBD = 0
+ ENDIF
+ IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
+ IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = SINGLECH *
+* *
+* what (1) = 1. Regge contribution (one chain) included *
+* default: 0. *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 390 CONTINUE
+ ISICHA = 0
+ IF (WHAT(1).EQ.ONE) ISICHA = 1
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = NOFRAGME *
+* *
+* biased chain hadronization *
+* *
+* what (1..6) = -1 no of hadronizsation of S-S chains *
+* = -2 no of hadronizsation of D-S chains *
+* = -3 no of hadronizsation of S-D chains *
+* = -4 no of hadronizsation of S-V chains *
+* = -5 no of hadronizsation of D-V chains *
+* = -6 no of hadronizsation of V-S chains *
+* = -7 no of hadronizsation of V-D chains *
+* = -8 no of hadronizsation of V-V chains *
+* = -9 no of hadronizsation of comb. chains *
+* default: complete hadronization *
+* sdum no meaning *
+* *
+*********************************************************************
+
+ 400 CONTINUE
+ DO 401 I=1,6
+ ICHAIN = INT(WHAT(I))
+ IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
+ & LHADRO(ABS(ICHAIN)) = .FALSE.
+ 401 CONTINUE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = HADRONIZE *
+* *
+* hadronization model and parameter switch *
+* *
+* what (1) = 1 hadronization via BAMJET *
+* = 2 hadronization via JETSET *
+* default: 2 *
+* what (2) = 1..3 parameter set to be used *
+* JETSET: 3 sets available *
+* ( = 3 default JETSET-parameters) *
+* BAMJET: 1 set available *
+* default: 1 *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 410 CONTINUE
+ IWHAT1 = INT(WHAT(1))
+ IWHAT2 = INT(WHAT(2))
+ IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
+ IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
+ & IFRAG(2) = IWHAT2
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = POPCORN *
+* *
+* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
+* *
+* what (1) = (PDB) frac. of diquark fragmenting directly into *
+* baryons (PYTHIA/JETSET fragmentation) *
+* (JETSET: = 0. Popcorn mechanism switched off) *
+* default: 0.5 *
+* what (2) = probability for accepting a diquark breaking *
+* diagram involving the generation of a u/d quark- *
+* antiquark pair default: 0.0 *
+* what (3) = same a what (2), here for s quark-antiquark pair *
+* default: 0.0 *
+* what (4..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 420 CONTINUE
+ IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
+ IF (WHAT(2).GE.0.0D0) THEN
+ PDBSEA(1) = WHAT(2)
+ PDBSEA(2) = WHAT(2)
+ ENDIF
+ IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
+ DO 421 I=1,8
+ DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
+ DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
+ DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
+ 421 CONTINUE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = PARDECAY *
+* *
+* what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
+* = 2. pion^0 decay after intranucl. cascade *
+* default: no decay *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 430 CONTINUE
+ IF (WHAT(1).EQ.ONE) ISIG0 = 1
+ IF (WHAT(1).EQ.2.0D0) IPI0 = 1
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = BEAM *
+* *
+* definition of beam parameters *
+* *
+* what (1/2) > 0 : energy of beam 1/2 (GeV) *
+* < 0 : abs(what(1/2)) energy per charge of *
+* beam 1/2 (GeV) *
+* (beam 1 is directed into positive z-direction) *
+* what (3) beam crossing angle, defined as 2x angle between *
+* one beam and the z-axis (micro rad) *
+* what (4) angle with x-axis defining the collision plane *
+* what (5..6), sdum no meaning *
+* *
+* Note: this card requires previously defined projectile and *
+* target identities (PROJPAR, TARPAR) *
+* *
+*********************************************************************
+
+ 440 CONTINUE
+ CALL DT_BEAMPR(WHAT,PPN,1)
+ EPN = ZERO
+ CMENER = ZERO
+ LEINP = .TRUE.
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LUND-MSTU *
+* *
+* set parameter MSTU in JETSET-common /LUDAT1/ *
+* *
+* what (1) = index according to LUND-common block *
+* what (2) = new value of MSTU( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-Lund or corresponding to *
+* the set given in HADRONIZE *
+* *
+*********************************************************************
+
+ 450 CONTINUE
+ IF (WHAT(1).GT.ZERO) THEN
+ NMSTU = NMSTU+1
+ IMSTU(NMSTU) = INT(WHAT(1))
+ MSTUX(NMSTU) = INT(WHAT(2))
+ ENDIF
+ IF (WHAT(3).GT.ZERO) THEN
+ NMSTU = NMSTU+1
+ IMSTU(NMSTU) = INT(WHAT(3))
+ MSTUX(NMSTU) = INT(WHAT(4))
+ ENDIF
+ IF (WHAT(5).GT.ZERO) THEN
+ NMSTU = NMSTU+1
+ IMSTU(NMSTU) = INT(WHAT(5))
+ MSTUX(NMSTU) = INT(WHAT(6))
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LUND-MSTJ *
+* *
+* set parameter MSTJ in JETSET-common /LUDAT1/ *
+* *
+* what (1) = index according to LUND-common block *
+* what (2) = new value of MSTJ( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-Lund or corresponding to *
+* the set given in HADRONIZE *
+* *
+*********************************************************************
+
+ 451 CONTINUE
+ IF (WHAT(1).GT.ZERO) THEN
+ NMSTJ = NMSTJ+1
+ IMSTJ(NMSTJ) = INT(WHAT(1))
+ MSTJX(NMSTJ) = INT(WHAT(2))
+ ENDIF
+ IF (WHAT(3).GT.ZERO) THEN
+ NMSTJ = NMSTJ+1
+ IMSTJ(NMSTJ) = INT(WHAT(3))
+ MSTJX(NMSTJ) = INT(WHAT(4))
+ ENDIF
+ IF (WHAT(5).GT.ZERO) THEN
+ NMSTJ = NMSTJ+1
+ IMSTJ(NMSTJ) = INT(WHAT(5))
+ MSTJX(NMSTJ) = INT(WHAT(6))
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LUND-MDCY *
+* *
+* set parameter MDCY(I,1) for particle decays in JETSET-common *
+* /LUDAT3/ *
+* *
+* what (1-6) = PDG particle index of particle which should *
+* not decay *
+* default: default-Lund or forced in *
+* DT_INITJS *
+* *
+*********************************************************************
+
+ 452 CONTINUE
+ DO 4521 I=1,6
+ IF (WHAT(I).NE.ZERO) THEN
+
+ KC = PYCOMP(INT(WHAT(I)))
+
+ MDCY(KC,1) = 0
+ ENDIF
+ 4521 CONTINUE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LUND-PARJ *
+* *
+* set parameter PARJ in JETSET-common /LUDAT1/ *
+* *
+* what (1) = index according to LUND-common block *
+* what (2) = new value of PARJ( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-Lund or corresponding to *
+* the set given in HADRONIZE *
+* *
+*********************************************************************
+
+ 460 CONTINUE
+ IF (WHAT(1).NE.ZERO) THEN
+ NPARJ = NPARJ+1
+ IPARJ(NPARJ) = INT(WHAT(1))
+ PARJX(NPARJ) = WHAT(2)
+ ENDIF
+ IF (WHAT(3).NE.ZERO) THEN
+ NPARJ = NPARJ+1
+ IPARJ(NPARJ) = INT(WHAT(3))
+ PARJX(NPARJ) = WHAT(4)
+ ENDIF
+ IF (WHAT(5).NE.ZERO) THEN
+ NPARJ = NPARJ+1
+ IPARJ(NPARJ) = INT(WHAT(5))
+ PARJX(NPARJ) = WHAT(6)
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LUND-PARU *
+* *
+* set parameter PARJ in JETSET-common /LUDAT1/ *
+* *
+* what (1) = index according to LUND-common block *
+* what (2) = new value of PARU( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-Lund or corresponding to *
+* the set given in HADRONIZE *
+* *
+*********************************************************************
+
+ 470 CONTINUE
+ IF (WHAT(1).GT.ZERO) THEN
+ NPARU = NPARU+1
+ IPARU(NPARU) = INT(WHAT(1))
+ PARUX(NPARU) = WHAT(2)
+ ENDIF
+ IF (WHAT(3).GT.ZERO) THEN
+ NPARU = NPARU+1
+ IPARU(NPARU) = INT(WHAT(3))
+ PARUX(NPARU) = WHAT(4)
+ ENDIF
+ IF (WHAT(5).GT.ZERO) THEN
+ NPARU = NPARU+1
+ IPARU(NPARU) = INT(WHAT(5))
+ PARUX(NPARU) = WHAT(6)
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = OUTLEVEL *
+* *
+* output control switches *
+* *
+* what (1) = internal rejection informations default: 0 *
+* what (2) = energy-momentum conservation check output *
+* default: 0 *
+* what (3) = internal warning messages default: 0 *
+* what (4..6), sdum not yet used *
+* *
+*********************************************************************
+
+ 480 CONTINUE
+ DO 481 K=1,6
+ IOULEV(K) = INT(WHAT(K))
+ 481 CONTINUE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = FRAME *
+* *
+* frame in which final state is given in DTEVT1 *
+* *
+* what (1) = 1 target rest frame (laboratory) *
+* = 2 nucleon-nucleon cms *
+* default: 1 *
+* *
+*********************************************************************
+
+ 490 CONTINUE
+ KFRAME = INT(WHAT(1))
+ IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = L-TAG *
+* *
+* lepton tagger: *
+* definition of kinematical cuts for radiated photon and *
+* outgoing lepton detection in lepton-nucleus interactions *
+* *
+* what (1) = y_min *
+* what (2) = y_max *
+* what (3) = Q^2_min *
+* what (4) = Q^2_max *
+* what (5) = theta_min (Lab) *
+* what (6) = theta_max (Lab) *
+* default: no cuts *
+* sdum no meaning *
+* *
+*********************************************************************
+
+ 500 CONTINUE
+ YMIN = WHAT(1)
+ YMAX = WHAT(2)
+ Q2MIN = WHAT(3)
+ Q2MAX = WHAT(4)
+ THMIN = WHAT(5)
+ THMAX = WHAT(6)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = L-ETAG *
+* *
+* lepton tagger: *
+* what (1) = min. outgoing lepton energy (in Lab) *
+* what (2) = min. photon energy (in Lab) *
+* what (3) = max. photon energy (in Lab) *
+* default: no cuts *
+* what (2..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 510 CONTINUE
+ ELMIN = MAX(WHAT(1),ZERO)
+ EGMIN = MAX(WHAT(2),ZERO)
+ EGMAX = MAX(WHAT(3),ZERO)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = ECMS-CUT *
+* *
+* what (1) = min. c.m. energy to be sampled *
+* what (2) = max. c.m. energy to be sampled *
+* what (3) = min x_Bj to be sampled *
+* default: no cuts *
+* what (3..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 520 CONTINUE
+ ECMIN = WHAT(1)
+ ECMAX = WHAT(2)
+ IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
+ XBJMIN = MAX(WHAT(3),ZERO)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = VDM-PAR1 *
+* *
+* parameters in gamma-nucleus cross section calculation *
+* *
+* what (1) = Lambda^2 default: 2. *
+* what (2) lower limit in M^2 integration *
+* = 1 (3m_pi)^2 *
+* = 2 (m_rho0)^2 *
+* = 3 (m_phi)^2 default: 1 *
+* what (3) upper limit in M^2 integration *
+* = 1 s/2 *
+* = 2 s/4 *
+* = 3 s default: 3 *
+* what (4) CKMT F_2 structure function *
+* = 2212 proton *
+* = 100 deuteron default: 2212 *
+* what (5) calculation of gamma-nucleon xsections *
+* = 1 according to CKMT-parametrization of F_2 *
+* = 2 integrating SIGVP over M^2 *
+* = 3 using SIGGA *
+* = 4 PHOJET cross sections default: 4 *
+* *
+* what (6), sdum no meaning *
+* *
+*********************************************************************
+
+ 530 CONTINUE
+ IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
+ IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
+ IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
+ IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
+ IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = HISTOGRAM *
+* *
+* activate different classes of histograms *
+* *
+* default: no histograms *
+* *
+*********************************************************************
+
+ 540 CONTINUE
+ DO 541 J=1,6
+ IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
+ IHISPP(INT(WHAT(J))-100) = 1
+ ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
+ IHISXS(INT(ABS(WHAT(J)))-200) = 1
+ IF (WHAT(J).LT.ZERO) IXSTBL = 1
+ ENDIF
+ 541 CONTINUE
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = XS-TABLE *
+* *
+* output of cross section table for requested interaction *
+* - particle production deactivated ! - *
+* *
+* what (1) lower energy limit for tabulation *
+* > 0 Lab. frame *
+* < 0 nucleon-nucleon cms *
+* what (2) upper energy limit for tabulation *
+* > 0 Lab. frame *
+* < 0 nucleon-nucleon cms *
+* what (3) > 0 # of equidistant lin. bins in E *
+* < 0 # of equidistant log. bins in E *
+* what (4) lower limit of particle virtuality (photons) *
+* what (5) upper limit of particle virtuality (photons) *
+* what (6) > 0 # of equidistant lin. bins in Q^2 *
+* < 0 # of equidistant log. bins in Q^2 *
+* *
+*********************************************************************
+
+ 550 CONTINUE
+ IF (WHAT(1).EQ.99999.0D0) THEN
+ IRATIO = INT(WHAT(2))
+ GOTO 10
+ ENDIF
+ CMENER = ABS(WHAT(2))
+ IF (.NOT.LXSTAB) THEN
+
+ CALL NCDTRD
+ CALL INCINI
+
+ ENDIF
+ IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
+ CMEOLD = CMENER
+ IF (WHAT(2).GT.ZERO)
+ & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
+ EPN = ZERO
+ PPN = ZERO
+C WRITE(LOUT,*) 'CMENER = ',CMENER
+ CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
+ CALL DT_PHOINI
+ ENDIF
+ CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
+ IXSQEL = 0
+ LXSTAB = .TRUE.
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = GLAUB-PAR *
+* *
+* parameters in Glauber-formalism *
+* *
+* what (1) # of nucleon configurations sampled in integration *
+* over nuclear desity default: 1000 *
+* what (2) # of bins for integration over impact-parameter and *
+* for profile-function calculation default: 49 *
+* what (3) = 1 calculation of tot., el. and qel. cross sections *
+* default: 0 *
+* what (4) = 1 read pre-calculated impact-parameter distrib. *
+* from "sdum".glb *
+* =-1 dump pre-calculated impact-parameter distrib. *
+* into "sdum".glb *
+* = 100 read pre-calculated impact-parameter distrib. *
+* for variable projectile/target/energy runs *
+* from "sdum".glb *
+* default: 0 *
+* what (5..6) no meaning *
+* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
+* *
+*********************************************************************
+
+ 560 CONTINUE
+ IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
+ IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
+ IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
+ IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
+ IOGLB = INT(WHAT(4))
+ CGLB = SDUM
+ ENDIF
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = GLAUB-INI *
+* *
+* pre-initialization of profile function *
+* *
+* what (1) lower energy limit for initialization *
+* > 0 Lab. frame *
+* < 0 nucleon-nucleon cms *
+* what (2) upper energy limit for initialization *
+* > 0 Lab. frame *
+* < 0 nucleon-nucleon cms *
+* what (3) > 0 # of equidistant lin. bins in E *
+* < 0 # of equidistant log. bins in E *
+* what (4) maximum projectile mass number for which the *
+* Glauber data are initialized for each *
+* projectile mass number *
+* (if <= mass given with the PROJPAR-card) *
+* default: 18 *
+* what (5) steps in mass number starting from what (4) *
+* up to mass number defined with PROJPAR-card *
+* for which Glauber data are initialized *
+* default: 5 *
+* what (6) no meaning *
+* sdum no meaning *
+* *
+*********************************************************************
+
+ 565 CONTINUE
+ IOGLB = -100
+ CALL DT_GLBINI(WHAT)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = VDM-PAR2 *
+* *
+* parameters in gamma-nucleus cross section calculation *
+* *
+* what (1) = 0 no suppression of shadowing by direct photon *
+* processes *
+* = 1 suppression .. default: 1 *
+* what (2) = 0 no suppression of shadowing by anomalous *
+* component if photon-F_2 *
+* = 1 suppression .. default: 1 *
+* what (3) = 0 no suppression of shadowing by coherence *
+* length of the photon *
+* = 1 suppression .. default: 1 *
+* what (4) = 1 longitudinal polarized photons are taken into *
+* account *
+* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
+* what (5..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 570 CONTINUE
+ IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
+ IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
+ IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
+ EPSPOL = WHAT(4)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: XS-QELPRO *
+* *
+* what (1..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 580 CONTINUE
+ IXSQEL = ABS(WHAT(1))
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: RNDMINIT *
+* *
+* initialization of random number generator *
+* *
+* what (1..4) values for initialization (= 1..168) *
+* what (5..6), sdum no meaning *
+* *
+*********************************************************************
+
+ 590 CONTINUE
+ IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
+ NA1 = 22
+ ELSE
+ NA1 = WHAT(1)
+ ENDIF
+ IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
+ NA2 = 54
+ ELSE
+ NA2 = WHAT(2)
+ ENDIF
+ IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
+ NA3 = 76
+ ELSE
+ NA3 = WHAT(3)
+ ENDIF
+ IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
+ NA4 = 92
+ ELSE
+ NA4 = WHAT(4)
+ ENDIF
+ CALL DT_RNDMST(NA1,NA2,NA3,NA4)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LEPTO-CUT *
+* *
+* set parameter CUT in LEPTO-common /LEPTOU/ *
+* *
+* what (1) = index in CUT-array *
+* what (2) = new value of CUT( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-LEPTO parameters *
+* *
+*********************************************************************
+
+ 600 CONTINUE
+ IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
+ IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
+ IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LEPTO-LST *
+* *
+* set parameter LST in LEPTO-common /LEPTOU/ *
+* *
+* what (1) = index in LST-array *
+* what (2) = new value of LST( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-LEPTO parameters *
+* *
+*********************************************************************
+
+ 610 CONTINUE
+ IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
+ IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
+ IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = LEPTO-PARL *
+* *
+* set parameter PARL in LEPTO-common /LEPTOU/ *
+* *
+* what (1) = index in PARL-array *
+* what (2) = new value of PARL( int(what(1)) ) *
+* what (3), what(4) and what (5), what(6) further *
+* parameter in the same way as what (1) and *
+* what (2) *
+* default: default-LEPTO parameters *
+* *
+*********************************************************************
+
+ 620 CONTINUE
+ IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
+ IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
+ IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
+ GOTO 10
+
+*********************************************************************
+* *
+* control card: codewd = START *
+* *
+* what (1) = number of events default: 100. *
+* what (2) = 0 Glauber initialization follows *
+* = 1 Glauber initialization supressed, fitted *
+* results are used instead *
+* (this does not apply if emulsion-treatment *
+* is requested) *
+* = 2 Glauber initialization is written to *
+* output-file shmakov.out *
+* = 3 Glauber initialization is read from input-file *
+* shmakov.out default: 0 *
+* what (3..6) no meaning *
+* what (3..6) no meaning *
+* *
+*********************************************************************
+
+ 630 CONTINUE
+
+* check for cross-section table output only
+ IF (LXSTAB) STOP
+
+ NCASES = INT(WHAT(1))
+ IF (NCASES.LE.0) NCASES = 100
+ IGLAU = INT(WHAT(2))
+ IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
+ & IGLAU = 0
+
+ NPMASS = IP
+ NPCHAR = IPZ
+ NTMASS = IT
+ NTCHAR = ITZ
+ IDP = IJPROJ
+ IDT = IJTARG
+ IF (IDP.LE.0) IDP = 1
+* muon neutrinos: temporary (missing index)
+* (new patch in projpar: therefore the following this is probably not
+* necessary anymore..)
+C IF (IDP.EQ.26) IDP = 5
+C IF (IDP.EQ.27) IDP = 6
+
+* redefine collision energy
+ IF (LEINP) THEN
+ IF (ABS(VAREHI).GT.ZERO) THEN
+ PDUM = ZERO
+ IF (VARELO.LT.EHADLO) VARELO = EHADLO
+ CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
+ PDUM = ZERO
+ CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
+ ENDIF
+ CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
+ ELSE
+ WRITE(LOUT,1003)
+ 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
+ & 1X,' -program stopped- ')
+ STOP
+ ENDIF
+
+* switch off evaporation (even if requested) if central coll. requ.
+ IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
+ IF (LEVPRT) THEN
+ WRITE(LOUT,1004)
+ 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
+ & ' central collisions forced.')
+ LEVPRT = .FALSE.
+ LDEEXG = .FALSE.
+ LHEAVY = .FALSE.
+ ENDIF
+ ENDIF
+
+* initialization of evaporation-module
+
+* initialize evaporation if the code is not used as Fluka event generator
+ WRITE(LOUT,*) ' ITRSPT = ', ITRSPT
+ IF (ITRSPT.NE.1) THEN
+ CALL NCDTRD
+ CALL INCINI
+ ENDIF
+ WRITE(LOUT,*) ' LEVPRT = ',LEVPRT
+ IF (LEVPRT) LHEAVY = .TRUE.
+* save the default JETSET-parameter
+ CALL DT_JSPARA(0)
+
+ WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE
+* force use of phojet for g-A
+ IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
+* initialization of nucleon-nucleon event generator
+ IF (MCGENE.EQ.2) CALL DT_PHOINI
+* initialization of LEPTO event generator
+ IF (MCGENE.EQ.3) THEN
+
+ STOP ' This version does not contain LEPTO !'
+
+ ENDIF
+
+* initialization of quasi-elastic neutrino scattering
+ IF (MCGENE.EQ.4) THEN
+ IF (IJPROJ.EQ.5) THEN
+ NEUTYP = 1
+ ELSEIF (IJPROJ.EQ.6) THEN
+ NEUTYP = 2
+ ELSEIF (IJPROJ.EQ.135) THEN
+ NEUTYP = 3
+ ELSEIF (IJPROJ.EQ.136) THEN
+ NEUTYP = 4
+ ELSEIF (IJPROJ.EQ.133) THEN
+ NEUTYP = 5
+ ELSEIF (IJPROJ.EQ.134) THEN
+ NEUTYP = 6
+ ENDIF
+ ENDIF
+
+* normalize fractions of emulsion components
+ IF (NCOMPO.GT.0) THEN
+ SUMFRA = ZERO
+ DO 491 I=1,NCOMPO
+ SUMFRA = SUMFRA+EMUFRA(I)
+ 491 CONTINUE
+ IF (SUMFRA.GT.ZERO) THEN
+ DO 492 I=1,NCOMPO
+ EMUFRA(I) = EMUFRA(I)/SUMFRA
+ 492 CONTINUE
+ ENDIF
+ ENDIF
+
+* disallow Cronin's multiple scattering for nucleus-nucleus interactions
+ IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
+ WRITE(LOUT,1005)
+ 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
+ MKCRON = 0
+ ENDIF
+
+* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
+C IF (NCOMPO.LE.0) THEN
+C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
+C ELSE
+C DO 493 I=1,NCOMPO
+C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
+C 493 CONTINUE
+C ENDIF
+
+* pre-tabulation of elastic cross-sections
+ CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
+
+ CALL DT_XTIME
+
+ RETURN
+
+*********************************************************************
+* *
+* control card: codewd = STOP *
+* *
+* stop of the event generation *
+* *
+* what (1..6) no meaning *
+* *
+*********************************************************************
+
+ 9999 CONTINUE
+ WRITE(LOUT,9000)
+ 9000 FORMAT(1X,'---> unexpected end of input !')
+
+ 640 CONTINUE
+ STOP
+
+ END
+
+*$ CREATE DT_KKINC.FOR
+*COPY DT_KKINC
+*
+*===kkinc==============================================================*
+*
+ SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
+ & IREJ)
+
+************************************************************************
+* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
+* This subroutine is an update of the previous version written *
+* by J. Ranft/ H.-J. Moehring. *
+* This version dated 19.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
+ & TINY2=1.0D-2,TINY3=1.0D-3)
+
+ LOGICAL LFZC
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* cuts for variable energy runs
+ COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ DIMENSION WHAT(6)
+
+ IREJ = 0
+ ILOOP = 0
+ 100 CONTINUE
+ IF (ILOOP.EQ.4) THEN
+ WRITE(LOUT,1000) NEVHKK
+ 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
+ GOTO 9999
+ ENDIF
+ ILOOP = ILOOP+1
+
+* variable energy-runs, recalculate parameters for LT's
+ IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
+ PDUM = ZERO
+ CDUM = ZERO
+ CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
+ ENDIF
+ IF (EPN.GT.EPROJ) THEN
+ WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
+ & ' Requested energy (',EPN,'GeV) exceeds',
+ & ' initialization energy (',EPROJ,'GeV) !'
+ STOP
+ ENDIF
+
+* re-initialize /DTPRTA/
+ IP = NPMASS
+ IPZ = NPCHAR
+ IT = NTMASS
+ ITZ = NTCHAR
+ IJPROJ = IDP
+ IBPROJ = IIBAR(IJPROJ)
+
+* calculate nuclear potentials (common /DTNPOT/)
+ CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
+
+* initialize treatment for residual nuclei
+ CALL DT_RESNCL(EPN,NLOOP,1)
+
+* sample hadron/nucleus-nucleus interaction
+ CALL DT_KKEVNT(KKMAT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
+ GOTO 9999
+ ENDIF
+
+ IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
+
+* intranuclear cascade of final state particles for KTAUGE generations
+* of secondaries
+ CALL DT_FOZOCA(LFZC,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
+ GOTO 9999
+ ENDIF
+
+* baryons unable to escape the nuclear potential are treated as
+* excited nucleons (ISTHKK=15,16)
+ CALL DT_SCN4BA
+
+* decay of resonances produced in intranuclear cascade processes
+**sr 15-11-95 should be obsolete
+C IF (LFZC) CALL DT_DECAY1
+
+ 101 CONTINUE
+* treatment of residual nuclei
+ CALL DT_RESNCL(EPN,NLOOP,2)
+
+* evaporation / fission / fragmentation
+* (if intranuclear cascade was sampled only)
+ IF (LFZC) THEN
+ CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
+ IF (IREJ1.GT.1) GOTO 101
+ IF (IREJ1.EQ.1) GOTO 100
+ ENDIF
+
+ ENDIF
+
+* rejection of unphysical configurations
+C CALL DT_REJUCO(1,IREJ1)
+C IF (IREJ1.GT.0) THEN
+C IF (IOULEV(1).GT.0)
+C & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
+C GOTO 100
+C ENDIF
+
+* transform finale state into Lab.
+ IFLAG = 2
+ CALL DT_BEAMPR(WHAT,DUM,IFLAG)
+ IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
+
+ IF (IPI0.EQ.1) CALL DT_DECPI0
+
+C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
+
+ RETURN
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DEFAUL.FOR
+*COPY DT_DEFAUL
+*
+*===defaul=============================================================*
+*
+ SUBROUTINE DT_DEFAUL(EPN,PPN)
+
+************************************************************************
+* Variables are set to default values. *
+* This version dated 8.5.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+ PARAMETER (TWOPI = 6.283185307179586454D+00)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* interface HADRIN-DPM
+ COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+* kinematical cuts for lepton-nucleus interactions
+ COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+ & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+
+* flags for activated histograms
+ COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+
+* cuts for variable energy runs
+ COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+
+* parameters for hA-diffraction
+ COMMON /DTDIHA/ DIBETA,DIALPH
+
+* LEPTO
+ REAL RPPN
+ COMMON /LEPTOI/ RPPN,LEPIN,INTER
+
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ DATA POTMES /0.002D0/
+
+* common /DTNPOT/
+ DO 10 I=1,2
+ PFERMP(I) = ZERO
+ PFERMN(I) = ZERO
+ EBINDP(I) = ZERO
+ EBINDN(I) = ZERO
+ DO 11 J=1,210
+ EPOT(I,J) = ZERO
+ 11 CONTINUE
+* nucleus independent meson potential
+ EPOT(I,13) = POTMES
+ EPOT(I,14) = POTMES
+ EPOT(I,15) = POTMES
+ EPOT(I,16) = POTMES
+ EPOT(I,23) = POTMES
+ EPOT(I,24) = POTMES
+ EPOT(I,25) = POTMES
+ 10 CONTINUE
+ FERMOD = 0.55D0
+ ETACOU(1) = ZERO
+ ETACOU(2) = ZERO
+ ICOUL = 1
+ LFERMI = .TRUE.
+
+* common /HNTHRE/
+ EHADTH = -99.0D0
+ EHADLO = 4.06D0
+ EHADHI = 6.0D0
+ INTHAD = 1
+ IDXTA = 2
+
+* common /DTIMPA/
+ ICENTR = 0
+ BIMIN = ZERO
+ BIMAX = 1.0D10
+ XSFRAC = 1.0D0
+
+* common /DTPRTA/
+ IP = 1
+ IPZ = 1
+ IT = 1
+ ITZ = 1
+ IJPROJ = 1
+ IBPROJ = 1
+ IJTARG = 1
+ IBTARG = 1
+* common /DTGPRO/
+ VIRT = ZERO
+ DO 14 I=1,4
+ PGAMM(I) = ZERO
+ PLEPT0(I) = ZERO
+ PLEPT1(I) = ZERO
+ PNUCL(I) = ZERO
+ 14 CONTINUE
+ IDIREC = 0
+
+* common /DTFOTI/
+**sr 7.4.98: changed after corrected B-sampling
+C TAUFOR = 4.4D0
+ TAUFOR = 3.5D0
+ KTAUGE = 25
+ ITAUVE = 1
+ INCMOD = 1
+ LPAULI = .TRUE.
+
+* common /DTCHAI/
+ SEASQ = ONE
+ MKCRON = 1
+ CRONCO = 0.64D0
+ ISICHA = 0
+ CUTOF = 100.0D0
+ LCO2CR = .FALSE.
+ IRECOM = 1
+ LINTPT = .TRUE.
+
+* common /DTXCUT/
+* definition of soft quark distributions
+ XSEACU = 0.05D0
+ UNON = 2.0D0
+ UNOM = 1.5D0
+ UNOSEA = 5.0D0
+* cutoff parameters for x-sampling
+ CVQ = 1.0D0
+ CDQ = 2.0D0
+C CSEA = 0.3D0
+ CSEA = 0.1D0
+ SSMIMA = 1.2D0
+ SSMIMQ = SSMIMA**2
+ VVMTHR = 2.0D0
+
+* common /DTXSFL/
+ IFLUCT = 0
+
+* common /DTFRPA/
+ PDB = 0.15D0
+ PDBSEA(1) = 0.0D0
+ PDBSEA(2) = 0.0D0
+ PDBSEA(3) = 0.0D0
+ ISIG0 = 0
+ IPI0 = 0
+ NMSTU = 0
+ NPARU = 0
+ NMSTJ = 0
+ NPARJ = 0
+
+* common /DTDIQB/
+ DO 15 I=1,8
+ DBRKR(1,I) = 5.0D0
+ DBRKR(2,I) = 5.0D0
+ DBRKR(3,I) = 10.0D0
+ DBRKA(1,I) = ZERO
+ DBRKA(2,I) = ZERO
+ DBRKA(3,I) = ZERO
+ 15 CONTINUE
+ CHAM1 = 0.2D0
+ CHAM3 = 0.5D0
+ CHAB1 = 0.7D0
+ CHAB3 = 1.0D0
+
+* common /DTFLG3/
+ ISINGD = 0
+ IDOUBD = 0
+ IFLAGD = 0
+ IDIFF = 0
+
+* common /DTMODL/
+ MCGENE = 2
+ CMODEL(1) = 'DTUNUC '
+ CMODEL(2) = 'PHOJET '
+ CMODEL(3) = 'LEPTO '
+ CMODEL(4) = 'QNEUTRIN'
+ LPHOIN = .TRUE.
+ ELOJET = 5.0D0
+
+* common /DTLCUT/
+ ECMIN = 3.5D0
+ ECMAX = 1.0D10
+ XBJMIN = ZERO
+ ELMIN = ZERO
+ EGMIN = ZERO
+ EGMAX = 1.0D10
+ YMIN = TINY10
+ YMAX = 0.999D0
+ Q2MIN = TINY10
+ Q2MAX = 10.0D0
+ THMIN = ZERO
+ THMAX = TWOPI
+ Q2LI = ZERO
+ Q2HI = 1.0D10
+ ECMLI = ZERO
+ ECMHI = 1.0D10
+
+* common /DTVDMP/
+ RL2 = 2.0D0
+ INTRGE(1) = 1
+ INTRGE(2) = 3
+ IDPDF = 2212
+ MODEGA = 4
+ ISHAD(1) = 1
+ ISHAD(2) = 1
+ ISHAD(3) = 1
+ EPSPOL = ZERO
+
+* common /DTGLGP/
+ JSTATB = 1000
+ JBINSB = 49
+ CGLB = ' '
+ IF (ITRSPT.EQ.1) THEN
+ IOGLB = 100
+ ELSE
+ IOGLB = 0
+ ENDIF
+ LPROD = .TRUE.
+
+* common /DTHIS3/
+ DO 16 I=1,50
+ IHISPP(I) = 0
+ IHISXS(I) = 0
+ 16 CONTINUE
+ IXSTBL = 0
+
+* common /DTVARE/
+ VARELO = ZERO
+ VAREHI = ZERO
+ VARCLO = ZERO
+ VARCHI = ZERO
+
+* common /DTDIHA/
+ DIBETA = -1.0D0
+ DIALPH = ZERO
+
+* common /LEPTOI/
+ RPPN = 0.0
+ LEPIN = 0
+ INTER = 0
+
+* common /QNEUTO/
+ NEUTYP = 1
+ NEUDEC = 0
+
+* common /DTEVNO/
+ NEVENT = 1
+ IF (ITRSPT.EQ.1) THEN
+ ICASCA = 1
+ ELSE
+ ICASCA = 0
+ ENDIF
+
+* default Lab.-energy
+ EPN = 200.0D0
+ PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
+
+ RETURN
+ END
+
+*$ CREATE DT_AAEVT.FOR
+*COPY DT_AAEVT
+*
+*===aaevt==============================================================*
+*
+ SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+ & IDP,IGLAU)
+
+************************************************************************
+* This version dated 22.03.96 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ CHARACTER*8 DATE,HHMMSS
+ CHARACTER*9 CHDATE,CHTIME,CHZONE
+ DIMENSION JDMNYR(8),IDMNYR(3)
+
+ KKMAT = 1
+ NMSG = MAX(NEVTS/100,1)
+
+* initialization of run-statistics and histograms
+ CALL DT_STATIS(1)
+
+ CALL PHO_PHIST(1000,DUM)
+
+* initialization of Glauber-formalism
+ IF (NCOMPO.LE.0) THEN
+ CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+ ELSE
+ DO 1 I=1,NCOMPO
+ CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+ 1 CONTINUE
+ ENDIF
+ CALL DT_SIGEMU
+
+C CALL IDATE(IDMNYR)
+C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
+ CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
+ WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+ & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
+ CALL ITIME(IDMNYR)
+ WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
+ & IDMNYR(1),IDMNYR(2),IDMNYR(3)
+ WRITE(LOUT,1001) DATE,HHMMSS
+ 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
+ & ' Time: ',A8,' )')
+
+* generate NEVTS events
+ DO 2 IEVT=1,NEVTS
+
+* print run-status message
+ IF (MOD(IEVT,NMSG).EQ.0) THEN
+C CALL IDATE(IDMNYR)
+C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
+ CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
+ WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+ & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
+ CALL ITIME(IDMNYR)
+ WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
+ & IDMNYR(1),IDMNYR(2),IDMNYR(3)
+ WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
+ 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
+ & ' Time: ',A,' )',/)
+C WRITE(LOUT,1000) IEVT-1
+C1000 FORMAT(1X,I8,' events sampled')
+ ENDIF
+ NEVENT = IEVT
+* treat nuclear emulsions
+ IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
+* composite targets only
+ KKMAT = -KKMAT
+* sample this event
+ CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
+
+ CALL PHO_PHIST(2000,DUM)
+
+ 2 CONTINUE
+
+* print run-statistics and histograms to output-unit 6
+
+ CALL PHO_PHIST(3000,DUM)
+
+ CALL DT_STATIS(2)
+
+ RETURN
+ END
+
+*$ CREATE DT_LAEVT.FOR
+*COPY DT_LAEVT
+*
+*===laevt==============================================================*
+*
+ SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+ & IDP,IGLAU)
+
+************************************************************************
+* Interface to run DPMJET for lepton-nucleus interactions. *
+* Kinematics is sampled using the equivalent photon approximation *
+* Based on GPHERA-routine by R. Engel. *
+* This version dated 23.03.96 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & ALPHEM = ONE/137.0D0)
+
+C CHARACTER*72 HEADER
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* kinematical cuts for lepton-nucleus interactions
+ COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+ & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* kinematics at lepton-gamma vertex
+ COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
+
+* flags for activated histograms
+ COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ DIMENSION XDUMB(40),BGTA(4)
+
+* LEPTO
+ IF (MCGENE.EQ.3) THEN
+
+ STOP ' This version does not contain LEPTO !'
+
+ ENDIF
+
+ KKMAT = 1
+ NMSG = MAX(NEVTS/10,1)
+
+* mass of incident lepton
+ AMLPT = AAM(IDP)
+ AMLPT2 = AMLPT**2
+ IDPPDG = IDT_IPDGHA(IDP)
+
+* consistency of kinematical limits
+ Q2MIN = MAX(Q2MIN,TINY10)
+ Q2MAX = MAX(Q2MAX,TINY10)
+ YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
+ YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
+
+* total energy of the lepton-nucleon system
+ PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
+ & +(PLEPT0(3)+PNUCL(3))**2 )
+ ETOTLN = PLEPT0(4)+PNUCL(4)
+ ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
+ ECMAX = MIN(ECMAX,ECMLN)
+ WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
+ & THMIN,THMAX,ELMIN
+ 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
+ & '------------------',/,9X,'W (min) =',
+ & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
+ & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
+ & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
+ & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
+ & F7.4,' for E_lpt >',F7.1,' GeV',/)
+
+* Lorentz-parameter for transf. into Lab
+ BGTA(1) = PNUCL(1)/AAM(1)
+ BGTA(2) = PNUCL(2)/AAM(1)
+ BGTA(3) = PNUCL(3)/AAM(1)
+ BGTA(4) = PNUCL(4)/AAM(1)
+* LT of incident lepton into Lab and dump it in DTEVT1
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
+ & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
+ & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
+* maximum energy of photon nucleon system
+ PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
+ & +(YMAX*PPL0(3)+PPA(3))**2)
+ ETOTGN = YMAX*PPL0(4)+PPA(4)
+ EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
+ EGNMAX = MIN(EGNMAX,ECMAX)
+* minimum energy of photon nucleon system
+ PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
+ & +(YMIN*PPL0(3)+PPA(3))**2)
+ ETOTGN = YMIN*PPL0(4)+PPA(4)
+ EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
+ EGNMIN = MAX(EGNMIN,ECMIN)
+
+* limits for Glauber-initialization
+ Q2LI = Q2MIN
+ Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
+ ECMLI = MAX(EGNMIN,THREE)
+ ECMHI = EGNMAX
+ WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
+ 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
+ & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
+ & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
+ & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
+ & ' GeV^2 (max) =',F7.1,' GeV^2',/)
+* initialization of Glauber-formalism
+ IF (NCOMPO.LE.0) THEN
+ CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+ ELSE
+ DO 9 I=1,NCOMPO
+ CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+ 9 CONTINUE
+ ENDIF
+ CALL DT_SIGEMU
+
+* initialization of run-statistics and histograms
+ CALL DT_STATIS(1)
+
+ CALL PHO_PHIST(1000,DUM)
+
+* maximum photon-nucleus cross section
+ I1 = 1
+ I2 = 1
+ RAT = ONE
+ IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RAT = ONE
+ ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
+ DO 5 I=2,NEBINI
+ IF (EGNMAX.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 6
+ ENDIF
+ 5 CONTINUE
+ 6 CONTINUE
+ ENDIF
+ SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
+ EGNXX = EGNMAX
+ I1 = 1
+ I2 = 1
+ RAT = ONE
+ IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RAT = ONE
+ ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
+ DO 7 I=2,NEBINI
+ IF (EGNMIN.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 8
+ ENDIF
+ 7 CONTINUE
+ 8 CONTINUE
+ ENDIF
+ SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
+ IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
+ SIGMAX = MAX(SIGMAX,SIGXX)
+ WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
+
+* plot photon flux table
+ AYMIN = LOG(YMIN)
+ AYMAX = LOG(YMAX)
+ AYRGE = AYMAX-AYMIN
+ MAXTAB = 50
+ ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
+C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
+ DO 1 I=1,MAXTAB
+ Y = EXP(AYMIN+ADY*DBLE(I-1))
+ Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
+ FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+ & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
+ FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+ & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
+C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
+ 1 CONTINUE
+
+* maximum residual weight for flux sampling (dy/y)
+ YY = YMIN
+ Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
+ WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
+ & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
+
+ CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
+ CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
+ CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
+ CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
+ CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
+ CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
+ CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
+ CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
+ CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
+ CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
+ CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
+ CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
+ XBLOW = 0.001D0
+ CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
+ CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
+ CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
+
+ ITRY = 0
+ ITRW = 0
+ NC0 = 0
+ NC1 = 0
+
+* generate events
+ DO 2 IEVT=1,NEVTS
+ IF (MOD(IEVT,NMSG).EQ.0) THEN
+C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
+C & STATUS='UNKNOWN')
+ WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
+C CLOSE(LDAT)
+ ENDIF
+ NEVENT = IEVT
+
+ 100 CONTINUE
+ ITRY = ITRY+1
+
+* sample y
+ 101 CONTINUE
+ ITRW = ITRW+1
+ YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
+ Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
+ Q2LOG = LOG(Q2MAX/Q2LOW)
+ WGH = (ONE+(ONE-YY)**2)*Q2LOG
+ & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
+ IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
+ 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
+ IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
+
+* sample Q2
+ YEFF = ONE+(ONE-YY)**2
+ 102 CONTINUE
+ Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
+ WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
+ IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
+
+c NC0 = NC0+1
+c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
+c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
+
+* kinematics at lepton-photon vertex
+* scattered electron
+ YQ2 = SQRT((ONE-YY)*Q2)
+ Q2E = Q2/(4.0D0*PLEPT0(4))
+ E1Y = (ONE-YY)*PLEPT0(4)
+ CALL DT_DSFECF(SIF,COF)
+ PLEPT1(1) = YQ2*COF
+ PLEPT1(2) = YQ2*SIF
+ PLEPT1(3) = E1Y-Q2E
+ PLEPT1(4) = E1Y+Q2E
+C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
+* radiated photon
+ PGAMM(1) = -PLEPT1(1)
+ PGAMM(2) = -PLEPT1(2)
+ PGAMM(3) = PLEPT0(3)-PLEPT1(3)
+ PGAMM(4) = PLEPT0(4)-PLEPT1(4)
+* E_cm cut
+ PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
+ & +(PGAMM(3)+PNUCL(3))**2 )
+ ETOTGN = PGAMM(4)+PNUCL(4)
+ ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
+ IF (ECMGN.LT.0.1D0) GOTO 101
+ ECMGN = SQRT(ECMGN)
+ IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
+
+* Lorentz-transformation into nucleon-rest system
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
+ & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
+ & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
+* temporary checks..
+ Q2TMP = ABS(PPG(4)**2-PGTOT**2)
+ IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
+ 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
+ & 2F10.4)
+ ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
+ IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
+ 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
+ & 2F10.2)
+ YYTMP = PPG(4)/PPL0(4)
+ IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
+ 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
+ & 2F10.4)
+
+* lepton tagger (Lab)
+ THETA = ACOS( PPL1(3)/PLTOT )
+ IF (PPL1(4).GT.ELMIN) THEN
+ IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
+ ENDIF
+* photon energy-cut (Lab)
+ IF (PPG(4).LT.EGMIN) GOTO 101
+ IF (PPG(4).GT.EGMAX) GOTO 101
+* x_Bj cut
+ XBJ = ABS(Q2/(1.876D0*PPG(4)))
+ IF (XBJ.LT.XBJMIN) GOTO 101
+
+ NC0 = NC0+1
+ CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
+ CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
+ CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
+ CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
+ CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
+
+* rotation angles against z-axis
+ COD = PPG(3)/PGTOT
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(PPG(1)**2+PPG(2)**2)
+ SID = PPT/PGTOT
+ COF = ONE
+ SIF = ZERO
+ IF (PGTOT*SID.GT.TINY10) THEN
+ COF = PPG(1)/(SID*PGTOT)
+ SIF = PPG(2)/(SID*PGTOT)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+
+ IF (IXSTBL.EQ.0) THEN
+* change to photon projectile
+ IJPROJ = 7
+* set virtuality
+ VIRT = Q2
+* re-initialize LTs with new kinematics
+* !!PGAMM ist set in cms (ECMGN) along z
+ EPN = ZERO
+ PPN = ZERO
+ CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
+* force Lab-system
+ IFRAME = 1
+* get emulsion component if requested
+ IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
+* convolute with cross section
+ CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
+ CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
+ IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
+ & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
+ & Q2,ECMGN,STOT
+ IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
+ NC1 = NC1+1
+ CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
+ CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
+ CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
+ CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
+ CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
+* composite targets only
+ KKMAT = -KKMAT
+* sample this event
+ CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
+ & IREJ)
+* rotate momenta of final state particles back in photon-nucleon syst.
+ DO 4 I=NPOINT(4),NHKK
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ PX = PHKK(1,I)
+ PY = PHKK(2,I)
+ PZ = PHKK(3,I)
+ CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I))
+ ENDIF
+ 4 CONTINUE
+ ENDIF
+
+ CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
+ CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
+ CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
+ CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
+ CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
+
+* dump this event to histograms
+
+ CALL PHO_PHIST(2000,DUM)
+
+ 2 CONTINUE
+
+ WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
+ WGY = WGY*LOG(YMAX/YMIN)
+ WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
+
+C HEADER = ' LAEVT: Q^2 distribution 0'
+C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: Q^2 distribution 1'
+C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: Q^2 distribution 2'
+C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: y distribution 0'
+C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: y distribution 1'
+C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: y distribution 2'
+C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: x distribution 0'
+C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: x distribution 1'
+C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: x distribution 2'
+C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_g distribution 0'
+C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_g distribution 1'
+C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_g distribution 2'
+C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_c distribution 0'
+C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_c distribution 1'
+C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C HEADER = ' LAEVT: E_c distribution 2'
+C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+
+* print run-statistics and histograms to output-unit 6
+
+ CALL PHO_PHIST(3000,DUM)
+
+ IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
+
+ RETURN
+ END
+
+*$ CREATE DT_DTUINI.FOR
+*COPY DT_DTUINI
+*
+*===dtuini=============================================================*
+*
+ SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+ & IDP,IEMU)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
+ CALL DT_STATIS(1)
+
+ CALL PHO_PHIST(1000,DUM)
+
+ IF (NCOMPO.LE.0) THEN
+ CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+ ELSE
+ DO 1 I=1,NCOMPO
+ CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+ 1 CONTINUE
+ ENDIF
+ IF (IOGLB.NE.100) CALL DT_SIGEMU
+ IEMU = IEMUL
+
+ RETURN
+ END
+
+*$ CREATE DT_DTUOUT.FOR
+*COPY DT_DTUOUT
+*
+*===dtuout=============================================================*
+*
+ SUBROUTINE DT_DTUOUT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CALL PHO_PHIST(3000,DUM)
+
+ CALL DT_STATIS(2)
+
+ RETURN
+ END
+
+*$ CREATE DT_BEAMPR.FOR
+*COPY DT_BEAMPR
+*
+*===beampr=============================================================*
+*
+ SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
+
+************************************************************************
+* Initialization of event generation *
+* This version dated 7.4.98 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+ PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+ LOGICAL LBEAM
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* beam momenta
+ COMMON /DTBEAM/ P1(4),P2(4)
+
+C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
+ DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
+
+ DATA LBEAM /.FALSE./
+
+ GOTO (1,2) MODE
+
+ 1 CONTINUE
+
+ E1 = WHAT(1)
+ IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
+ E2 = WHAT(2)
+ IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
+ PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
+ PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
+ TH = 1.D-6*WHAT(3)/2.D0
+ PH = WHAT(4)*BOG
+ P1(1) = PP1*SIN(TH)*COS(PH)
+ P1(2) = PP1*SIN(TH)*SIN(PH)
+ P1(3) = PP1*COS(TH)
+ P1(4) = E1
+ P2(1) = PP2*SIN(TH)*COS(PH)
+ P2(2) = PP2*SIN(TH)*SIN(PH)
+ P2(3) = -PP2*COS(TH)
+ P2(4) = E2
+ ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
+ & -(P1(3)+P2(3))**2 )
+ ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
+ PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
+ BGX = (P1(1)+P2(1))/ECM
+ BGY = (P1(2)+P2(2))/ECM
+ BGZ = (P1(3)+P2(3))/ECM
+ BGE = (P1(4)+P2(4))/ECM
+ CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
+ & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
+ CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
+ & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
+ COD = P1CMS(3)/P1TOT
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
+ SID = PPT/P1TOT
+ COF = ONE
+ SIF = ZERO
+ IF (P1TOT*SID.GT.TINY10) THEN
+ COF = P1CMS(1)/(SID*P1TOT)
+ SIF = P1CMS(2)/(SID*P1TOT)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+**check
+C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
+C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
+C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
+C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
+C PAX = ZERO
+C PAY = ZERO
+C PAZ = P1TOT
+C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
+C PBX = ZERO
+C PBY = ZERO
+C PBZ = -P2TOT
+C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
+C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
+C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
+C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
+C & P1CMS(1),P1CMS(2),P1CMS(3))
+C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
+C & P2CMS(1),P2CMS(2),P2CMS(3))
+C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
+C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
+C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
+C & P1TOT,P1(1),P1(2),P1(3),P1(4))
+C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
+C & P2TOT,P2(1),P2(2),P2(3),P2(4))
+C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
+C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
+C STOP
+**
+
+ LBEAM = .TRUE.
+
+ RETURN
+
+ 2 CONTINUE
+
+ IF (LBEAM) THEN
+ IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+ DO 20 I=NPOINT(4),NHKK
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
+ PECMS = PHKK(4,I)
+ CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
+ & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
+ ENDIF
+ 20 CONTINUE
+ ELSE
+ MODE = -1
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_REJUCO.FOR
+*COPY DT_REJUCO
+*
+*===rejuco=============================================================*
+*
+ SUBROUTINE DT_REJUCO(MODE,IREJ)
+
+************************************************************************
+* REJection of Unphysical COnfigurations *
+* MODE = 1 rejection of particles with unphysically large energy *
+* *
+* This version dated 27.12.2006 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+ PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+* maximum x_cms of final state particle
+ PARAMETER (XCMSMX = 1.4D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+ IREJ = 0
+
+ IF (MODE.EQ.1) THEN
+ IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+ ECMHLF = UMO/2.0D0
+ DO 10 I=NPOINT(4),NHKK
+ IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
+ XCMS = ABS(PHKK(4,I))/ECMHLF
+ IF (XCMS.GT.XCMSMX) GOTO 9999
+ ENDIF
+ 10 CONTINUE
+ ENDIF
+
+ RETURN
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*$ CREATE DT_EVENTB.FOR
+*COPY DT_EVENTB
+*
+*===eventb=============================================================*
+*
+ SUBROUTINE DT_EVENTB(NCSY,IREJ)
+
+************************************************************************
+* Treatment of nucleon-nucleon interactions with full two-component *
+* Dual Parton Model. *
+* NCSY number of nucleon-nucleon interactions *
+* IREJ rejection flag *
+* This version dated 14.01.2000 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+*! uncomment this line for internal phojet-fragmentation
+C #include "dtu_dtevtp.inc"
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
+ COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* statistics: double-Pomeron exchange
+ COMMON /DTFLG2/ INTFLG,IPOPO
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C initial state parton radiation (internal part)
+ INTEGER MXISR3,MXISR4
+ PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
+ INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
+ DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
+ COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
+ & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
+ & IFL1(2,MXISR3),IFL2(2,MXISR3),
+ & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
+
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+ DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
+ & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
+ & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
+ & KPRON(15),ISINGL(2000)
+
+* initial values for max. number of phojet scatterings and dtunuc chains
+* to be fragmented with one pyexec call
+ DATA MXPHFR,MXDTFR /10,100/
+
+ IREJ = 0
+* pointer to first parton of the first chain in dtevt common
+ NPOINT(3) = NHKK+1
+* special flag for double-Pomeron statistics
+ IPOPO = 1
+* counter for low-mass (DTUNUC) interactions
+ NDTUSC = 0
+* counter for interactions treated by PHOJET
+ NPHOSC = 0
+
+* scan interactions for single nucleon-nucleon interactions
+* (this has to be checked here because Cronin modifies parton momenta)
+ NC = NPOINT(2)
+ IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
+ DO 8 I=1,NCSY
+ ISINGL(I) = 0
+ MOP = JMOHKK(1,NC)
+ MOT = JMOHKK(1,NC+1)
+ DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
+ DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
+ IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
+ NC = NC+4
+ 8 CONTINUE
+
+* multiple scattering of chain ends
+ IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
+ IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
+
+* switch to PHOJET-settings for JETSET parameter
+ CALL DT_INITJS(1)
+
+* loop over nucleon-nucleon interaction
+ NC = NPOINT(2)
+ DO 2 I=1,NCSY
+*
+* pick up one nucleon-nucleon interaction from DTEVT1
+* ppnn / ptnn - momenta of the interacting nucleons (cms)
+* ptotnn - total momentum of the interacting nucleons (cms)
+* pp1,2 / pt1,2 - momenta of the four partons
+* pp / pt - total momenta of the proj / targ partons
+* ptot - total momentum of the four partons
+ MOP = JMOHKK(1,NC)
+ MOT = JMOHKK(1,NC+1)
+ DO 3 K=1,4
+ PPNN(K) = PHKK(K,MOP)
+ PTNN(K) = PHKK(K,MOT)
+ PTOTNN(K) = PPNN(K)+PTNN(K)
+ PP1(K) = PHKK(K,NC)
+ PT1(K) = PHKK(K,NC+1)
+ PP2(K) = PHKK(K,NC+2)
+ PT2(K) = PHKK(K,NC+3)
+ PP(K) = PP1(K)+PP2(K)
+ PT(K) = PT1(K)+PT2(K)
+ PTOT(K) = PP(K)+PT(K)
+ 3 CONTINUE
+*
+*-----------------------------------------------------------------------
+* this is a complete nucleon-nucleon interaction
+*
+ IF (ISINGL(I).EQ.1) THEN
+*
+* initialize PHOJET-variables for remnant/valence-partons
+ IHFLD(1,1) = 0
+ IHFLD(1,2) = 0
+ IHFLD(2,1) = 0
+ IHFLD(2,2) = 0
+ IHFLS(1) = 1
+ IHFLS(2) = 1
+* save current settings of PHOJET process and min. bias flags
+ DO 9 K=1,11
+ KPRON(K) = IPRON(K,1)
+ 9 CONTINUE
+ ISWSAV = ISWMDL(2)
+*
+* check if forced sampling of diffractive interaction requested
+ IF (ISINGD.LT.-1) THEN
+ DO 90 K=1,11
+ IPRON(K,1) = 0
+ 90 CONTINUE
+ IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
+ IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
+ IF (ISINGD.EQ.-5) IPRON(4,1) = 1
+ ENDIF
+*
+* for photons: a direct/anomalous interaction is not sampled
+* in PHOJET but already in Glauber-formalism. Here we check if such
+* an interaction is requested
+ IF (IJPROJ.EQ.7) THEN
+* first switch off direct interactions
+ IPRON(8,1) = 0
+* this is a direct interactions
+ IF (IDIREC.EQ.1) THEN
+ DO 12 K=1,11
+ IPRON(K,1) = 0
+ 12 CONTINUE
+ IPRON(8,1) = 1
+* this is an anomalous interactions
+* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
+ ELSEIF (IDIREC.EQ.2) THEN
+ ISWMDL(2) = 0
+ ENDIF
+ ELSE
+ IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
+ ENDIF
+*
+* make sure that total momenta of partons, pp and pt, are on mass
+* shell (Cronin may have srewed this up..)
+ CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
+ IF (IR1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
+ & 'EVENTB: mass shell correction rejected'
+ GOTO 9999
+ ENDIF
+*
+* initialize the incoming particles in PHOJET
+ IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
+
+ CALL PHO_SETPAR(1,22,0,VIRT)
+
+ ELSE
+
+ CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
+
+ ENDIF
+
+ CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
+
+*
+* initialize rejection loop counter for anomalous processes
+ IRJANO = 0
+ 800 CONTINUE
+ IRJANO = IRJANO+1
+*
+* temporary fix for ifano problem
+ IFANO(1) = 0
+ IFANO(2) = 0
+*
+* generate complete hadron/nucleon/photon-nucleon event with PHOJET
+
+ CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
+
+*
+* for photons: special consistency check for anomalous interactions
+ IF (IJPROJ.EQ.7) THEN
+ IF (IRJANO.LT.30) THEN
+ IF (IFANO(1).NE.0) THEN
+* here, an anomalous interaction was generated. Check if it
+* was also requested. Otherwise reject this event.
+ IF (IDIREC.EQ.0) GOTO 800
+ ELSE
+* here, an anomalous interaction was not generated. Check if it
+* was requested in which case we need to reject this event.
+ IF (IDIREC.EQ.2) GOTO 800
+ ENDIF
+ ELSE
+ WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
+ & IRJANO,IDIREC,NEVHKK
+ ENDIF
+ ENDIF
+*
+* copy back original settings of PHOJET process and min. bias flags
+ DO 10 K=1,11
+ IPRON(K,1) = KPRON(K)
+ 10 CONTINUE
+ ISWMDL(2) = ISWSAV
+*
+* check if PHOJET has rejected this event
+ IF (IREJ1.NE.0) THEN
+C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
+ WRITE(LOUT,'(1X,A,I4)')
+ & 'EVENTB: chain system rejected',IDIREC
+
+ CALL PHO_PREVNT(0)
+
+ GOTO 9999
+ ENDIF
+*
+* copy partons and strings from PHOJET common back into DTEVT for
+* external fragmentation
+ MO1 = NC
+ MO2 = NC+3
+*! uncomment this line for internal phojet-fragmentation
+C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
+ NPHOSC = NPHOSC+1
+ CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
+ GOTO 9999
+ ENDIF
+*
+* update statistics counter
+ ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
+*
+*-----------------------------------------------------------------------
+* this interaction involves "remnants"
+*
+ ELSE
+*
+* total mass of this system
+ PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
+ AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
+ IF (AMTOT2.LT.ZERO) THEN
+ AMTOT = ZERO
+ ELSE
+ AMTOT = SQRT(AMTOT2)
+ ENDIF
+*
+* systems with masses larger than elojet are treated with PHOJET
+ IF (AMTOT.GT.ELOJET) THEN
+*
+* initialize PHOJET-variables for remnant/valence-partons
+* projectile parton flavors and valence flag
+ IHFLD(1,1) = IDHKK(NC)
+ IHFLD(1,2) = IDHKK(NC+2)
+ IHFLS(1) = 0
+ IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
+ & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
+* target parton flavors and valence flag
+ IHFLD(2,1) = IDHKK(NC+1)
+ IHFLD(2,2) = IDHKK(NC+3)
+ IHFLS(2) = 0
+ IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
+ & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
+* flag signalizing PHOJET how to treat the remnant:
+* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
+* iremn > -1 valence remnant: PHOJET assumes flavors according
+* to mother particle
+ IREMN1 = IHFLS(1)-1
+ IREMN2 = IHFLS(2)-1
+*
+* initialize the incoming particles in PHOJET
+ IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
+
+ CALL PHO_SETPAR(1,22,IREMN1,VIRT)
+
+ ELSE
+
+ CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
+
+ ENDIF
+
+ CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
+
+*
+* calculate Lorentz parameter of the nucleon-nucleon cm-system
+ PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
+ AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
+ BGX = PTOTNN(1)/AMNN
+ BGY = PTOTNN(2)/AMNN
+ BGZ = PTOTNN(3)/AMNN
+ GAM = PTOTNN(4)/AMNN
+* transform interacting nucleons into nucleon-nucleon cm-system
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+ & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
+ & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+ & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
+ & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
+* transform (total) momenta of the proj and targ partons into
+* nucleon-nucleon cm-system
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+ & PP(1),PP(2),PP(3),PP(4),
+ & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+ & PT(1),PT(2),PT(3),PT(4),
+ & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
+* energy fractions of the proj and targ partons
+ XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
+ XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
+***
+* testprint
+c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
+c & (PPTCMS(2)+PTTCMS(2))**2 +
+c & (PPTCMS(3)+PTTCMS(3))**2 )
+c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
+c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
+c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
+c & (PPSUB(2)+PTSUB(2))**2 +
+c & (PPSUB(3)+PTSUB(3))**2 )
+c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
+c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
+***
+*
+* save current settings of PHOJET process and min. bias flags
+ DO 7 K=1,11
+ KPRON(K) = IPRON(K,1)
+ 7 CONTINUE
+* disallow direct photon int. (does not make sense here anyway)
+ IPRON(8,1) = 0
+* disallow double pomeron processes (due to technical problems
+* in PHOJET, needs to be solved sometime)
+ IPRON(4,1) = 0
+* disallow diffraction for sea-diquarks
+ IF ((IABS(IHFLD(1,1)).GT.1100).AND.
+ & (IABS(IHFLD(1,2)).GT.1100)) THEN
+ IPRON(3,1) = 0
+ IPRON(6,1) = 0
+ ENDIF
+ IF ((IABS(IHFLD(2,1)).GT.1100).AND.
+ & (IABS(IHFLD(2,2)).GT.1100)) THEN
+ IPRON(3,1) = 0
+ IPRON(5,1) = 0
+ ENDIF
+*
+* we need massless partons: transform them on mass shell
+ XMP = ZERO
+ XMT = ZERO
+ DO 6 K=1,4
+ PPTMP(K) = PPSUB(K)
+ PTTMP(K) = PTSUB(K)
+ 6 CONTINUE
+ CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
+ PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
+ PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
+ PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
+ & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
+* total energy of the subsysten after mass transformation
+* (should be the same as before..)
+ SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
+ & (PPSUB(4)+PTSUB(4)+PSUTOT) )
+*
+* after mass shell transformation the x_sub - relation has to be
+* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
+*
+* The old version was to scale based on the original x_sub and the
+* 4-momenta of the subsystem. At very high energy this could lead to
+* "pseudo-cm energies" of the parent system considerably exceeding
+* the true cm energy. Now we keep the true cm energy and calculate
+* new x_sub instead.
+C old version PPTCMS(4) = PPSUB(4)/XPSUB
+ PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
+ XPSUB = PPSUB(4)/PPTCMS(4)
+ IF (IJPROJ.EQ.7) THEN
+ AMP2 = PHKK(5,MOT)**2
+ PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
+ ELSE
+*???????
+ PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
+ & *(PPTCMS(4)+PHKK(5,MOP)))
+C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
+C & *(PPTCMS(4)+PHKK(5,MOT)))
+ ENDIF
+C old version PTTCMS(4) = PTSUB(4)/XTSUB
+ PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
+ XTSUB = PTSUB(4)/PTTCMS(4)
+ PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
+ & *(PTTCMS(4)+PHKK(5,MOT)))
+ DO 4 K=1,3
+ PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
+ PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
+ 4 CONTINUE
+***
+* testprint
+*
+* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
+* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
+* pptcms/ pttcms - momenta of the interacting nucleons (cms)
+* pp1,2 / pt1,2 - momenta of the four partons
+*
+* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
+* ptot - total momentum of the four partons (cms, negl. Fermi)
+* ppsub / ptsub - total momenta of the proj / targ partons (cms)
+*
+c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
+c & (PPTCMS(2)+PTTCMS(2))**2 +
+c & (PPTCMS(3)+PTTCMS(3))**2 )
+c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
+c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
+c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
+c & (PPSUB(2)+PTSUB(2))**2 +
+c & (PPSUB(3)+PTSUB(3))**2 )
+c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
+c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
+c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
+c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
+c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
+c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
+c ENDIF
+c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
+c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
+c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
+c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
+* transform interacting nucleons into nucleon-nucleon cm-system
+c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
+c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
+c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
+c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
+c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
+c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
+c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
+c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
+c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
+c & (PPNEW2+PTNEW2)**2 +
+c & (PPNEW3+PTNEW3)**2 )
+c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
+c & (PPNEW4+PTNEW4+PTSTCM) )
+c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
+c & (PPSUB2+PTSUB2)**2 +
+c & (PPSUB3+PTSUB3)**2 )
+c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
+c & (PPSUB4+PTSUB4+PTSTSU) )
+C WRITE(*,*) ' mother cmE :'
+C WRITE(*,*) ETSTCM,ENEWCM
+C WRITE(*,*) ' subsystem cmE :'
+C WRITE(*,*) ETSTSU,ENEWSU
+C WRITE(*,*) ' projectile mother :'
+C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
+C WRITE(*,*) ' target mother :'
+C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
+C WRITE(*,*) ' projectile subsystem:'
+C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
+C WRITE(*,*) ' target subsystem:'
+C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
+C WRITE(*,*) ' projectile subsystem should be:'
+C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
+C & XPSUB*ETSTCM/2.0D0
+C WRITE(*,*) ' target subsystem should be:'
+C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
+C & XTSUB*ETSTCM/2.0D0
+C WRITE(*,*) ' subsystem cmE should be: '
+C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
+***
+*
+* generate complete remnant - nucleon/remnant event with PHOJET
+
+ CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
+
+*
+* copy back original settings of PHOJET process flags
+ DO 11 K=1,11
+ IPRON(K,1) = KPRON(K)
+ 11 CONTINUE
+*
+* check if PHOJET has rejected this event
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
+ WRITE(LOUT,*)
+ & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
+
+ CALL PHO_PREVNT(0)
+
+ GOTO 9999
+ ENDIF
+*
+* copy partons and strings from PHOJET common back into DTEVT for
+* external fragmentation
+ MO1 = NC
+ MO2 = NC+3
+*! uncomment this line for internal phojet-fragmentation
+C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
+ NPHOSC = NPHOSC+1
+ CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
+ & 'EVENTB: chain system rejected 2'
+ GOTO 9999
+ ENDIF
+*
+* update statistics counter
+ ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
+*
+*-----------------------------------------------------------------------
+* two-chain approx. for smaller systems
+*
+ ELSE
+*
+ NDTUSC = NDTUSC+1
+* special flag for double-Pomeron statistics
+ IPOPO = 0
+*
+* pick up flavors at the ends of the two chains
+ IFP1 = IDHKK(NC)
+ IFT1 = IDHKK(NC+1)
+ IFP2 = IDHKK(NC+2)
+ IFT2 = IDHKK(NC+3)
+* ..and the indices of the mothers
+ MOP1 = NC
+ MOT1 = NC+1
+ MOP2 = NC+2
+ MOT2 = NC+3
+ CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
+ & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
+*
+* check if this chain system was rejected
+ IF (IREJ1.GT.0) THEN
+ IF (IOULEV(1).GT.0) THEN
+ WRITE(LOUT,*) 'rejected 1 in EVENTB'
+ WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
+ & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
+ ENDIF
+ IRHHA = IRHHA+1
+ GOTO 9999
+ ENDIF
+* the following lines are for sea-sea chains rejected in GETCSY
+ IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
+ ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
+ ENDIF
+*
+ ENDIF
+*
+* update statistics counter
+ ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
+*
+ NC = NC+4
+*
+ 2 CONTINUE
+*
+*-----------------------------------------------------------------------
+* treatment of low-mass chains (if there are any)
+*
+ IF (NDTUSC.GT.0) THEN
+*
+* correct chains of very low masses for possible resonances
+ IF (IRESCO.EQ.1) THEN
+ CALL DT_EVTRES(IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
+ IRRES(1) = IRRES(1)+1
+ GOTO 9999
+ ENDIF
+ ENDIF
+* fragmentation of low-mass chains
+*! uncomment this line for internal phojet-fragmentation
+* (of course it will still be fragmented by DPMJET-routines but it
+* has to be done here instead of further below)
+C CALL DT_EVTFRA(IREJ1)
+C IF (IREJ1.GT.0) THEN
+C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
+C IRFRAG = IRFRAG+1
+C GOTO 9999
+C ENDIF
+ ELSE
+*! uncomment this line for internal phojet-fragmentation
+C NPOINT(4) = NHKK+1
+ IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
+ ENDIF
+*
+*-----------------------------------------------------------------------
+* new di-quark breaking mechanisms
+*
+ MXLEFT = 2
+ CALL DT_CHASTA(0)
+ IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
+ & .OR.(PDBSEA(3).GT.0.0D0)) THEN
+ CALL DT_DIQBRK
+ MXLEFT = 4
+ ENDIF
+*
+*-----------------------------------------------------------------------
+* hadronize this event
+*
+* hadronize PHOJET chain systems
+ NPYMAX = 0
+ NPJE = NPHOSC/MXPHFR
+ IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
+ IF (NPJE.GT.1) THEN
+ NLEFT = NPHOSC-NPJE*MXPHFR
+ DO 20 JFRG=1,NPJE
+ NFRG = JFRG*MXPHFR
+ IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
+ CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+ IF (IREJ1.GT.0) GOTO 22
+ NLEFT = 0
+ ELSE
+ CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
+ IF (IREJ1.GT.0) GOTO 22
+ ENDIF
+ IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+ 20 CONTINUE
+ IF (NLEFT.GT.0) THEN
+ CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+ IF (IREJ1.GT.0) GOTO 22
+ IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+ ENDIF
+ ELSE
+ CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+ IF (IREJ1.GT.0) GOTO 22
+ IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+ ENDIF
+*
+* check max. filling level of jetset common and
+* reduce mxphfr if necessary
+ IF (NPYMAX.GT.3000) THEN
+ IF (NPYMAX.GT.3500) THEN
+ MXPHFR = MAX(1,MXPHFR-2)
+ ELSE
+ MXPHFR = MAX(1,MXPHFR-1)
+ ENDIF
+C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
+ ENDIF
+*
+* hadronize DTUNUC chain systems
+ 23 CONTINUE
+ IBACK = MXDTFR
+ CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
+ IF (IREJ2.GT.0) GOTO 22
+*
+* check max. filling level of jetset common and
+* reduce mxdtfr if necessary
+ IF (NPYMEM.GT.3000) THEN
+ IF (NPYMEM.GT.3500) THEN
+ MXDTFR = MAX(1,MXDTFR-20)
+ ELSE
+ MXDTFR = MAX(1,MXDTFR-10)
+ ENDIF
+C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
+ ENDIF
+*
+ IF (IBACK.EQ.-1) GOTO 23
+*
+ 22 CONTINUE
+C CALL DT_EVTFRG(1,IREJ1)
+C CALL DT_EVTFRG(2,IREJ2)
+ IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
+ IRFRAG = IRFRAG+1
+ GOTO 9999
+ ENDIF
+*
+* get final state particles from /DTEVTP/
+*! uncomment this line for internal phojet-fragmentation
+C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
+
+ IF (IJPROJ.NE.7)
+ & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
+C IF (IREJ3.NE.0) GOTO 9999
+
+ RETURN
+
+ 9999 CONTINUE
+ IREVT = IREVT+1
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_GETPJE.FOR
+*COPY DT_GETPJE
+*
+*===getpje=============================================================*
+*
+ SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
+
+************************************************************************
+* This subroutine copies PHOJET partons and strings from POEVT1 into *
+* DTEVT1. *
+* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
+* PP,PT 4-momenta of projectile/target being handled by *
+* PHOJET *
+* This version dated 11.12.99 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
+ & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
+
+ LOGICAL LFLIP
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
+ COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* statistics: double-Pomeron exchange
+ COMMON /DTFLG2/ INTFLG,IPOPO
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+ DIMENSION PP(4),PT(4)
+ DATA MAXLOP /10000/
+
+ INHKK = NHKK
+ LFLIP = .TRUE.
+ 1 CONTINUE
+ NPVAL = 0
+ NTVAL = 0
+ IREJ = 0
+
+* store initial momenta for energy-momentum conservation check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
+ CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
+ ENDIF
+* copy partons and strings from POEVT1 into DTEVT1
+ DO 11 I=1,ISTR
+C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
+ IF (NCODE(I).EQ.-99) THEN
+ IDXSTG = NPOS(1,I)
+ IDSTG = IDHEP(IDXSTG)
+ PX = PHEP(1,IDXSTG)
+ PY = PHEP(2,IDXSTG)
+ PZ = PHEP(3,IDXSTG)
+ PE = PHEP(4,IDXSTG)
+ IF (MODE.LT.0) THEN
+ ISTAT = 70000+IPJE
+ CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
+ & 11,IDSTG,0)
+ IF (LEMCCK) THEN
+ PX = -PX
+ PY = -PY
+ PZ = -PZ
+ PE = -PE
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ ELSE
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+ & PPX,PPY,PPZ,PPE)
+ ISTAT = 70000+IPJE
+ CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
+ & 11,IDSTG,0)
+ IF (LEMCCK) THEN
+ PX = -PPX
+ PY = -PPY
+ PZ = -PPZ
+ PE = -PPE
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ ENDIF
+ NOBAM(NHKK) = 0
+ IHIST(1,NHKK) = IPHIST(1,IDXSTG)
+ IHIST(2,NHKK) = 0
+ ELSEIF (NCODE(I).GE.0) THEN
+* indices of partons and string in POEVT1
+ IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
+ IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
+ IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
+ WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
+ & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
+ STOP ' GETPJE 1'
+ ENDIF
+ IDXSTG = NPOS(1,I)
+* find "mother" string of the string
+ IDXMS1 = ABS(JMOHEP(1,IDX1))
+ IDXMS2 = ABS(JMOHEP(1,IDX2))
+ IF (IDXMS1.NE.IDXMS2) THEN
+ IDXMS1 = IDXSTG
+ IDXMS2 = IDXSTG
+C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
+ ENDIF
+* search POEVT1 for the original hadron of the parton
+ ILOOP = 0
+ IPOM1 = 0
+ 14 CONTINUE
+ ILOOP = ILOOP+1
+
+ IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
+
+ IDXMS1 = ABS(JMOHEP(1,IDXMS1))
+ IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
+ & (ILOOP.LT.MAXLOP)) GOTO 14
+ IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
+ IPOM2 = 0
+ ILOOP = 0
+ 15 CONTINUE
+ ILOOP = ILOOP+1
+
+ IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
+
+ IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
+ IDXMS2 = ABS(JMOHEP(2,IDXMS2))
+ ELSE
+ IDXMS2 = ABS(JMOHEP(1,IDXMS2))
+ ENDIF
+ IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
+ & (ILOOP.LT.MAXLOP)) GOTO 15
+ IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
+* parton 1
+ IF (IDXMS1.EQ.1) THEN
+ ISPTN1 = ISTHKK(MO1)
+ M1PTN1 = MO1
+ M2PTN1 = MO1+2
+ ELSE
+ ISPTN1 = ISTHKK(MO2)
+ M1PTN1 = MO2-2
+ M2PTN1 = MO2
+ ENDIF
+* parton 2
+ IF (IDXMS2.EQ.1) THEN
+ ISPTN2 = ISTHKK(MO1)
+ M1PTN2 = MO1
+ M2PTN2 = MO1+2
+ ELSE
+ ISPTN2 = ISTHKK(MO2)
+ M1PTN2 = MO2-2
+ M2PTN2 = MO2
+ ENDIF
+* check for mis-identified mothers and switch mother indices if necessary
+ IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
+ & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
+ & (LFLIP)) THEN
+ IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
+ ISPTN1 = ISTHKK(MO1)
+ M1PTN1 = MO1
+ M2PTN1 = MO1+2
+ ISPTN2 = ISTHKK(MO2)
+ M1PTN2 = MO2-2
+ M2PTN2 = MO2
+ ELSE
+ ISPTN1 = ISTHKK(MO2)
+ M1PTN1 = MO2-2
+ M2PTN1 = MO2
+ ISPTN2 = ISTHKK(MO1)
+ M1PTN2 = MO1
+ M2PTN2 = MO1+2
+ ENDIF
+ ENDIF
+* register partons in temporary common
+* parton at chain end
+ PX = PHEP(1,IDX1)
+ PY = PHEP(2,IDX1)
+ PZ = PHEP(3,IDX1)
+ PE = PHEP(4,IDX1)
+* flag only partons coming from Pomeron with 41/42
+C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
+ IF (IPOM1.NE.0) THEN
+ ISTX = ABS(ISPTN1)/10
+ IMO = ABS(ISPTN1)-10*ISTX
+ ISPTN1 = -(40+IMO)
+ ELSE
+ IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
+ ISTX = ABS(ISPTN1)/10
+ IMO = ABS(ISPTN1)-10*ISTX
+ IF ((IDHEP(IDX1).EQ.21).OR.
+ & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
+ ISPTN1 = -(60+IMO)
+ ELSE
+ ISPTN1 = -(50+IMO)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
+ IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
+ IF (MODE.LT.0) THEN
+ CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
+ & PZ,PE,0,0,0)
+ ELSE
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+ & PPX,PPY,PPZ,PPE)
+ CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
+ & PPZ,PPE,0,0,0)
+ ENDIF
+ IHIST(1,NHKK) = IPHIST(1,IDX1)
+ IHIST(2,NHKK) = 0
+ DO 19 KK=1,4
+ VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
+ WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
+ 19 CONTINUE
+ VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
+ WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
+ M1STRG = NHKK
+* gluon kinks
+ NGLUON = IDX2-IDX1-1
+ IF (NGLUON.GT.0) THEN
+ DO 17 IGLUON=1,NGLUON
+ IDX = IDX1+IGLUON
+ IDXMS = ABS(JMOHEP(1,IDX))
+ IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
+ ILOOP = 0
+ 16 CONTINUE
+ ILOOP = ILOOP+1
+ IDXMS = ABS(JMOHEP(1,IDXMS))
+ IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
+ & (ILOOP.LT.MAXLOP)) GOTO 16
+ IF (ILOOP.EQ.MAXLOP)
+ & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
+ ENDIF
+ IF (IDXMS.EQ.1) THEN
+ ISPTN = ISTHKK(MO1)
+ M1PTN = MO1
+ M2PTN = MO1+2
+ ELSE
+ ISPTN = ISTHKK(MO2)
+ M1PTN = MO2-2
+ M2PTN = MO2
+ ENDIF
+ PX = PHEP(1,IDX)
+ PY = PHEP(2,IDX)
+ PZ = PHEP(3,IDX)
+ PE = PHEP(4,IDX)
+ IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
+ ISTX = ABS(ISPTN)/10
+ IMO = ABS(ISPTN)-10*ISTX
+ IF ((IDHEP(IDX).EQ.21).OR.
+ & (ABS(IPHIST(1,IDX)).GE.100)) THEN
+ ISPTN = -(60+IMO)
+ ELSE
+ ISPTN = -(50+IMO)
+ ENDIF
+ ENDIF
+ IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
+ IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
+ IF (MODE.LT.0) THEN
+ CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
+ & PX,PY,PZ,PE,0,0,0)
+ ELSE
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+ & PPX,PPY,PPZ,PPE)
+ CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
+ & PPX,PPY,PPZ,PPE,0,0,0)
+ ENDIF
+ IHIST(1,NHKK) = IPHIST(1,IDX)
+ IHIST(2,NHKK) = 0
+ DO 20 KK=1,4
+ VHKK(KK,NHKK) = VHKK(KK,M2PTN)
+ WHKK(KK,NHKK) = WHKK(KK,M1PTN)
+ 20 CONTINUE
+ VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
+ WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
+ 17 CONTINUE
+ ENDIF
+* parton at chain end
+ PX = PHEP(1,IDX2)
+ PY = PHEP(2,IDX2)
+ PZ = PHEP(3,IDX2)
+ PE = PHEP(4,IDX2)
+* flag only partons coming from Pomeron with 41/42
+C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
+ IF (IPOM2.NE.0) THEN
+ ISTX = ABS(ISPTN2)/10
+ IMO = ABS(ISPTN2)-10*ISTX
+ ISPTN2 = -(40+IMO)
+ ELSE
+ IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
+ ISTX = ABS(ISPTN2)/10
+ IMO = ABS(ISPTN2)-10*ISTX
+ IF ((IDHEP(IDX2).EQ.21).OR.
+ & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
+ ISPTN2 = -(60+IMO)
+ ELSE
+ ISPTN2 = -(50+IMO)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
+ IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
+ IF (MODE.LT.0) THEN
+ CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
+ & PX,PY,PZ,PE,0,0,0)
+ ELSE
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+ & PPX,PPY,PPZ,PPE)
+ CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
+ & PPX,PPY,PPZ,PPE,0,0,0)
+ ENDIF
+ IHIST(1,NHKK) = IPHIST(1,IDX2)
+ IHIST(2,NHKK) = 0
+ DO 21 KK=1,4
+ VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
+ WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
+ 21 CONTINUE
+ VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
+ WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
+ M2STRG = NHKK
+* register string
+ JSTRG = 100*IPROCE+NCODE(I)
+ PX = PHEP(1,IDXSTG)
+ PY = PHEP(2,IDXSTG)
+ PZ = PHEP(3,IDXSTG)
+ PE = PHEP(4,IDXSTG)
+ IF (MODE.LT.0) THEN
+ ISTAT = 70000+IPJE
+ CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
+ & PX,PY,PZ,PE,0,0,0)
+ IF (LEMCCK) THEN
+ PX = -PX
+ PY = -PY
+ PZ = -PZ
+ PE = -PE
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ ELSE
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+ & PPX,PPY,PPZ,PPE)
+ ISTAT = 70000+IPJE
+ CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
+ & PPX,PPY,PPZ,PPE,0,0,0)
+ IF (LEMCCK) THEN
+ PX = -PPX
+ PY = -PPY
+ PZ = -PPZ
+ PE = -PPE
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ ENDIF
+ NOBAM(NHKK) = 0
+ IHIST(1,NHKK) = 0
+ IHIST(2,NHKK) = 0
+ DO 18 KK=1,4
+ VHKK(KK,NHKK) = VHKK(KK,MO2)
+ WHKK(KK,NHKK) = WHKK(KK,MO1)
+ 18 CONTINUE
+ VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
+ WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
+ ENDIF
+ 11 CONTINUE
+
+ IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
+ NHKK = INHKK
+ LFLIP = .FALSE.
+ GOTO 1
+ ENDIF
+
+ IF (LEMCCK) THEN
+ IF (UMO.GT.1.0D5) THEN
+ CHKLEV = 1.0D0
+ ELSE
+ CHKLEV = TINY1
+ ENDIF
+ CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
+
+ IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
+
+ ENDIF
+
+* internal statistics
+* dble-Po statistics.
+ IF (IPROCE.NE.4) IPOPO = 0
+
+ INTFLG = IPROCE
+ IDCHSY = IDCH(MO1)
+ IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
+ ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
+ ELSE
+ WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
+ 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
+ & ') at evt(chain) ',I6,'(',I2,')')
+ ENDIF
+ IF (IPROCE.EQ.5) THEN
+ IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
+ ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
+ ELSE
+C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+ 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
+ & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
+ ENDIF
+ ELSEIF (IPROCE.EQ.6) THEN
+ IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
+ ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
+ ELSE
+C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+ ENDIF
+ ELSEIF (IPROCE.EQ.7) THEN
+ IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
+ & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
+ IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
+ & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
+ IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
+ & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
+ IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
+ & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
+ IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
+ & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
+ ELSE
+ WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+ ENDIF
+ ENDIF
+ IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
+ & THEN
+ ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+ ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+ ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+ ENDIF
+ ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
+ ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
+ ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
+ ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
+ ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_PHOINI.FOR
+*COPY DT_PHOINI
+*
+*===phoini=============================================================*
+*
+ SUBROUTINE DT_PHOINI
+
+************************************************************************
+* Initialization PHOJET-event generator for nucleon-nucleon interact. *
+* This version dated 16.11.95 is written by S. Roesler *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+*
+* parameters for cascade calculations:
+* maximum mumber of PDF's which can be defined in phojet (limited
+* by the dimension of ipdfs in pho_setpdf)
+ PARAMETER (MAXPDF = 20)
+* PDF parametrization and number of set for the first 30 hadrons in
+* the bamjet-code list
+* negative numbers mean that the PDF is set in phojet,
+* zero stands for "not a hadron"
+ DIMENSION IPARPD(30),ISETPD(30)
+* PDF parametrization
+ DATA IPARPD /
+ & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
+ & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
+* number of set
+ DATA ISETPD /
+ & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
+ & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
+
+**PHOJET105a
+C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C PARAMETER ( MAXPRO = 16 )
+C PARAMETER ( MAXTAB = 20 )
+C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
+C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
+C CHARACTER*8 MDLNA
+C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
+**PHOJET110
+
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+**
+ DIMENSION PP(4),PT(4)
+
+ LOGICAL LSTART
+ DATA LSTART /.TRUE./
+
+ IJP = IJPROJ
+ IJT = IJTARG
+ Q2 = VIRT
+* lepton-projectiles: initialize real photon instead
+ IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
+ IJP = 7
+ Q2 = ZERO
+ ENDIF
+
+ IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
+
+* switch Reggeon off
+C IPAMDL(3)= 0
+ IF (IP.EQ.1) THEN
+ IFPAP(1) = IDT_IPDGHA(IJP)
+ IFPAB(1) = IJP
+ ELSE
+ IFPAP(1) = 2212
+ IFPAB(1) = IDT_ICIHAD(IFPAP(1))
+ ENDIF
+ PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
+ PVIRT(1) = PMASS(1)**2
+ IF (IT.EQ.1) THEN
+ IFPAP(2) = IDT_IPDGHA(IJT)
+ IFPAB(2) = IJT
+ ELSE
+ IFPAP(2) = 2212
+ IFPAB(2) = IDT_ICIHAD(IFPAP(2))
+ ENDIF
+ PMASS(2) = AAM(IFPAB(2))
+ PVIRT(2) = ZERO
+ DO 1 K=1,4
+ PP(K) = ZERO
+ PT(K) = ZERO
+ 1 CONTINUE
+* get max. possible momenta of incoming particles to be used for PHOJET ini.
+ PPF = ZERO
+ PTF = ZERO
+ SCPF= 1.5D0
+ IF (UMO.GE.1.E5) THEN
+ SCPF= 5.0D0
+ ENDIF
+ IF (NCOMPO.GT.0) THEN
+ DO 2 I=1,NCOMPO
+ IF (IT.GT.1) THEN
+ CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
+ ELSE
+ CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
+ ENDIF
+ PPFTMP = MAX(PFERMP(1),PFERMN(1))
+ PTFTMP = MAX(PFERMP(2),PFERMN(2))
+ IF (PPFTMP.GT.PPF) PPF = PPFTMP
+ IF (PTFTMP.GT.PTF) PTF = PTFTMP
+ 2 CONTINUE
+ ELSE
+ CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
+ PPF = MAX(PFERMP(1),PFERMN(1))
+ PTF = MAX(PFERMP(2),PFERMN(2))
+ ENDIF
+ PTF = -PTF
+ PPF = SCPF*PPF
+ PTF = SCPF*PTF
+ IF (IJP.EQ.7) THEN
+ AMP2 = SIGN(PMASS(1)**2,PMASS(1))
+ PP(3) = PPCM
+ PP(4) = SQRT(AMP2+PP(3)**2)
+ ELSE
+ EPF = SQRT(PPF**2+PMASS(1)**2)
+ CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
+ ENDIF
+ ETF = SQRT(PTF**2+PMASS(2)**2)
+ CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
+ ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
+ & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
+ IF (LSTART) THEN
+ WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
+ 1001 FORMAT(
+ & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
+ & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
+ IF (NCOMPO.GT.0) THEN
+ WRITE(LOUT,1002) SCPF,PTF,PT
+ ELSE
+ WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
+ ENDIF
+ 1002 FORMAT(
+ & ' DT_PHOINI: PHOJET initialized for target emulsion ',
+ & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
+ 1003 FORMAT(
+ & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
+ & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
+ WRITE(LOUT,1004) ECMINI
+ 1004 FORMAT(' E_cm = ',E10.3)
+ IF (IJP.EQ.8) WRITE(LOUT,1005)
+ 1005 FORMAT(
+ & ' DT_PHOINI: warning! proton parameters used for neutron',
+ & ' projectile')
+ LSTART = .FALSE.
+ ENDIF
+* switch off new diffractive cross sections at low energies for nuclei
+* (temporary solution)
+ IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
+ WRITE(LOUT,'(1X,A)')
+ & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
+ CALL PHO_SETMDL(30,0,1)
+ ENDIF
+*
+C IF (IJP.EQ.7) THEN
+C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
+C PP(3) = PPCM
+C PP(4) = SQRT(AMP2+PP(3)**2)
+C ELSE
+C PFERMX = ZERO
+C IF (IP.GT.1) PFERMX = 0.5D0
+C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
+C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
+C ENDIF
+C PFERMX = ZERO
+C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
+C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
+C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
+**sr 26.10.96
+ ISAV = IPAMDL(13)
+ IF ((ISHAD(2).EQ.1).AND.
+ & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
+ & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
+**
+
+ CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
+
+**sr 26.10.96
+ IPAMDL(13) = ISAV
+**
+*
+* patch for cascade calculations:
+* define parton distribution functions for other hadrons, i.e. other
+* then defined already in phojet
+ IF (IOGLB.EQ.100) THEN
+ WRITE(LOUT,1006)
+ 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
+ & ' assiged (ID,IPAR,ISET)',/)
+ NPDF = 0
+ DO 3 I=1,30
+ IF (IPARPD(I).NE.0) THEN
+ NPDF = NPDF+1
+ IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
+ IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
+ IDPDG = IDT_IPDGHA(I)
+ IPAR = IPARPD(I)
+ ISET = ISETPD(I)
+ WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
+ CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+ ENDIF
+
+C CALL PHO_PHIST(-1,SIGMAX)
+
+ IF (IREJ1.NE.0) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
+ STOP
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_EVENTD.FOR
+*COPY DT_EVENTD
+*
+*===eventd=============================================================*
+*
+ SUBROUTINE DT_EVENTD(IREJ)
+
+************************************************************************
+* Quasi-elastic neutrino nucleus scattering. *
+* This version dated 29.04.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
+ PARAMETER (SQTINF=1.0D+15)
+
+ LOGICAL LFIRST
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+
+ COMMON /QNPOL/ POLARX(4),PMODUL
+
+ INTEGER PYK
+
+ DATA LFIRST /.TRUE./
+
+ IREJ = 0
+
+ IF (LFIRST) THEN
+ LFIRST = .FALSE.
+ CALL DT_MASS_INI
+ ENDIF
+
+* JETSET parameter
+ CALL DT_INITJS(0)
+
+* interacting target nucleon
+ LTYP = NEUTYP
+ IF (NEUDEC.LE.9) THEN
+ IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
+ NUCTYP = 2112
+ NUCTOP = 2
+ ELSE
+ NUCTYP = 2212
+ NUCTOP = 1
+ ENDIF
+ ELSE
+ RTYP = DT_RNDM(RTYP)
+ ZFRAC = DBLE(ITZ)/DBLE(IT)
+ IF (RTYP.LE.ZFRAC) THEN
+ NUCTYP = 2212
+ NUCTOP = 1
+ ELSE
+ NUCTYP = 2112
+ NUCTOP = 2
+ ENDIF
+ ENDIF
+
+* select first nucleon in list with matching id and reset all other
+* nucleons which have been marked as "wounded" by ININUC
+ IFOUND = 0
+ DO 1 I=1,NHKK
+ IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
+ ISTHKK(I) = 12
+ IFOUND = 1
+ IDX = I
+ ELSE
+ IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
+ ENDIF
+ 1 CONTINUE
+ IF (IFOUND.EQ.0)
+ & STOP ' EVENTD: interacting target nucleon not found! '
+
+* correct position of proj. lepton: assume position of target nucleon
+ DO 3 I=1,4
+ VHKK(I,1) = VHKK(I,IDX)
+ WHKK(I,1) = WHKK(I,IDX)
+ 3 CONTINUE
+
+* load initial momenta for conservation check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
+ CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
+ & 2,IDUM,IDUM)
+ ENDIF
+
+* quasi-elastic scattering
+ IF (NEUDEC.LT.9) THEN
+ CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
+ & PHKK(4,IDX),PHKK(5,IDX))
+* CC event on p or n
+ ELSEIF (NEUDEC.EQ.10) THEN
+ CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
+ & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
+* NC event on p or n
+ ELSEIF (NEUDEC.EQ.11) THEN
+ CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
+ & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
+ ENDIF
+
+* get final state particles from Lund-common and write them into HKKEVT
+ NPOINT(1) = NHKK+1
+ NPOINT(4) = NHKK+1
+
+ NLINES = PYK(0,1)
+
+ NHKK0 = NHKK+1
+ DO 4 I=4,NLINES
+ IF (K(I,1).EQ.1) THEN
+ ID = K(I,2)
+ PX = P(I,1)
+ PY = P(I,2)
+ PZ = P(I,3)
+ PE = P(I,4)
+ CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
+ IDBJ = IDT_ICIHAD(ID)
+ EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
+ IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
+ IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
+ ENDIF
+ VHKK(1,NHKK) = VHKK(1,IDX)
+ VHKK(2,NHKK) = VHKK(2,IDX)
+ VHKK(3,NHKK) = VHKK(3,IDX)
+ VHKK(4,NHKK) = VHKK(4,IDX)
+C IF (I.EQ.4) THEN
+C WHKK(1,NHKK) = POLARX(1)
+C WHKK(2,NHKK) = POLARX(2)
+C WHKK(3,NHKK) = POLARX(3)
+C WHKK(4,NHKK) = POLARX(4)
+C ELSE
+ WHKK(1,NHKK) = WHKK(1,IDX)
+ WHKK(2,NHKK) = WHKK(2,IDX)
+ WHKK(3,NHKK) = WHKK(3,IDX)
+ WHKK(4,NHKK) = WHKK(4,IDX)
+C ENDIF
+ IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+ ENDIF
+ 4 CONTINUE
+
+ IF (LEMCCK) THEN
+ CHKLEV = TINY5
+ CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
+ IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
+ ENDIF
+
+* transform momenta into cms (as required for inc etc.)
+ DO 5 I=NHKK0,NHKK
+ IF (ISTHKK(I).EQ.1) THEN
+ CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
+ PHKK(3,I) = PZ
+ PHKK(4,I) = PE
+ ENDIF
+ 5 CONTINUE
+
+ RETURN
+ END
+*$ CREATE DT_KKEVNT.FOR
+*COPY DT_KKEVNT
+*
+*===kkevnt=============================================================*
+*
+ SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
+
+************************************************************************
+* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
+* without nuclear effects (one event). *
+* This subroutine is an update of the previous version (KKEVT) written *
+* by J. Ranft/ H.-J. Moehring. *
+* This version dated 20.04.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* interface HADRIN-DPM
+ COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* coordinates of nucleons
+ COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
+
+* interface between Glauber formalism and DPM
+ COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
+ & INTER1(MAXINT),INTER2(MAXINT)
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+**temporary
+
+* statistics: Glauber-formalism
+ COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+**
+
+ DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
+
+ IREJ = 0
+ ICREQU = ICREQU+1
+ NC = 0
+
+ 1 CONTINUE
+ ICSAMP = ICSAMP+1
+ NC = NC+1
+ IF (MOD(NC,10).EQ.0) THEN
+ WRITE(LOUT,1000) NEVHKK
+ 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
+ GOTO 9999
+ ENDIF
+
+* initialize DTEVT1/DTEVT2
+ CALL DT_EVTINI
+
+* We need the following only in order to sample nucleon coordinates.
+* However we don't have parameters (cross sections, slope etc.)
+* for neutrinos available. Therefore switch projectile to proton
+* in this case.
+ IF (MCGENE.EQ.4) THEN
+ JJPROJ = 1
+ ELSE
+ JJPROJ = IJPROJ
+ ENDIF
+
+ 10 CONTINUE
+ IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
+* make sure that Glauber-formalism is called each time the interaction
+* configuration changed
+ & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
+ & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
+* sample number of nucleon-nucleon coll. according to Glauber-form.
+ CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
+ NWTSAM = NN
+ NWASAM = NP
+ NWBSAM = NT
+ NEVOLD = NEVHKK
+ IPOLD = IP
+ ITOLD = IT
+ JJPOLD = JJPROJ
+ EPROLD = EPROJ
+ ENDIF
+
+* force diffractive particle production in h-K interactions
+ IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
+ & (IP.EQ.1).AND.(NN.NE.1)) THEN
+ NEVOLD = 0
+ GOTO 10
+ ENDIF
+
+* check number of involved proj. nucl. (NP) if central prod.is requested
+ IF (ICENTR.GT.0) THEN
+ CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
+ IF (IBACK.GT.0) GOTO 10
+ ENDIF
+
+* get initial nucleon-configuration in projectile and target
+* rest-system (including Fermi-momenta if requested)
+ CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
+ MODE = 2
+ IF (EPROJ.LE.EHADTH) MODE = 3
+ CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
+
+ IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
+
+* activate HADRIN at low energies (implemented for h-N scattering only)
+ IF (EPROJ.LE.EHADHI) THEN
+ IF (EHADTH.LT.ZERO) THEN
+* smooth transition btwn. DPM and HADRIN
+ FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
+ RR = DT_RNDM(FRAC)
+ IF (RR.GT.FRAC) THEN
+ IF (IP.EQ.1) THEN
+ CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
+ IF (IREJ1.GT.0) GOTO 1
+ RETURN
+ ELSE
+ WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
+ ENDIF
+ ENDIF
+ ELSE
+* fixed threshold for onset of production via HADRIN
+ IF (EPROJ.LE.EHADTH) THEN
+ IF (IP.EQ.1) THEN
+ CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
+ IF (IREJ1.GT.0) GOTO 1
+ RETURN
+ ELSE
+ WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
+ & I3,') with target (m=',I3,')',/,11X,
+ & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
+ & 'GeV) cannot be handled')
+
+* sampling of momentum-x fractions & flavors of chain ends
+ CALL DT_SPLPTN(NN)
+
+* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
+ CALL DT_NUC2CM
+
+* collect momenta of chain ends and put them into DTEVT1
+ CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
+ IF (IREJ1.NE.0) GOTO 1
+
+ ENDIF
+
+* handle chains including fragmentation (two-chain approximation)
+ IF (MCGENE.EQ.1) THEN
+* two-chain approximation
+ CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
+ GOTO 1
+ ENDIF
+ ELSEIF (MCGENE.EQ.2) THEN
+* multiple-Po exchange including minijets
+ CALL DT_EVENTB(NCSY,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
+ GOTO 1
+ ENDIF
+ ELSEIF (MCGENE.EQ.3) THEN
+ STOP ' This version does not contain LEPTO !'
+
+ ELSEIF (MCGENE.EQ.4) THEN
+* quasi-elastic neutrino scattering
+ CALL DT_EVENTD(IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
+ GOTO 1
+ ENDIF
+ ELSE
+ WRITE(LOUT,1002) MCGENE
+ 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
+ & ' not available - program stopped')
+ STOP
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_CHKCEN.FOR
+*COPY DT_CHKCEN
+*
+*===chkcen=============================================================*
+*
+ SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
+
+************************************************************************
+* Check of number of involved projectile nucleons if central production*
+* is requested. *
+* Adopted from a part of the old KKEVT routine which was written by *
+* J. Ranft/H.-J.Moehring. *
+* This version dated 13.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+ IBACK = 0
+
+* old version
+ IF (ICENTR.EQ.2) THEN
+ IF (IP.LT.IT) THEN
+ IF (IP.LE.8) THEN
+ IF (NP.LT.IP-1) IBACK = 1
+ ELSEIF (IP.LE.16) THEN
+ IF (NP.LT.IP-2) IBACK = 1
+ ELSEIF (IP.LE.32) THEN
+ IF (NP.LT.IP-3) IBACK = 1
+ ELSEIF (IP.GE.33) THEN
+ IF (NP.LT.IP-5) IBACK = 1
+ ENDIF
+ ELSEIF (IP.EQ.IT) THEN
+ IF (IP.EQ.32) THEN
+ IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
+ ELSE
+ IF (NP.LT.IP-IP/8) IBACK = 1
+ ENDIF
+ ELSEIF (ABS(IP-IT).LT.3) THEN
+ IF (NP.LT.IP-IP/8) IBACK = 1
+ ENDIF
+ ELSE
+* new version (DPMJET, 5.6.99)
+ IF (IP.LT.IT) THEN
+ IF (IP.LE.8) THEN
+ IF (NP.LT.IP-1) IBACK = 1
+ ELSEIF (IP.LE.16) THEN
+ IF (NP.LT.IP-2) IBACK = 1
+ ELSEIF (IP.LT.32) THEN
+ IF (NP.LT.IP-3) IBACK = 1
+ ELSEIF (IP.GE.32) THEN
+ IF (IT.LE.150) THEN
+* Example: S-Ag
+ IF (NP.LT.IP-1) IBACK = 1
+ ELSE
+* Example: S-Au
+ IF (NP.LT.IP) IBACK = 1
+ ENDIF
+ ENDIF
+ ELSEIF (IP.EQ.IT) THEN
+* Example: S-S
+ IF (IP.EQ.32) THEN
+ IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
+* Example: Pb-Pb
+ ELSE
+ IF (NP.LT.IP-IP/4) IBACK = 1
+ ENDIF
+ ELSEIF (ABS(IP-IT).LT.3) THEN
+ IF (NP.LT.IP-IP/8) IBACK = 1
+ ENDIF
+ ENDIF
+
+ ICCPRO = ICCPRO+1
+
+ RETURN
+ END
+
+*$ CREATE DT_ININUC.FOR
+*COPY DT_ININUC
+*
+*===ininuc=============================================================*
+*
+ SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
+
+************************************************************************
+* Samples initial configuration of nucleons in nucleus with mass NMASS *
+* including Fermi-momenta (if reqested). *
+* ID BAMJET-code for hadrons (instead of nuclei) *
+* NMASS mass number of nucleus (number of nucleons) *
+* NCH charge of nucleus *
+* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
+* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
+* IMODE = 1 projectile nucleus *
+* = 2 target nucleus *
+* = 3 target nucleus (E_lab<E_thr for HADRIN) *
+* Adopted from a part of the old KKEVT routine which was written by *
+* J. Ranft/H.-J.Moehring. *
+* This version dated 13.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (FM2MM=1.0D-12)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* flavors of partons (DTUNUC 1.x)
+ COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+ & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+ & IPSQ(MAXSQU),IPSQ2(MAXSQU),
+ & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+ & ITSQ(MAXSQU),ITSQ2(MAXSQU),
+ & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+ & KKPROJ(MAXVQU),KKTARG(MAXVQU)
+
+* interface HADRIN-DPM
+ COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+ DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
+
+* number of neutrons
+ NNEU = NMASS-NCH
+* initializations
+ NP = 0
+ NN = 0
+ DO 1 K=1,4
+ PFTOT(K) = 0.0D0
+ 1 CONTINUE
+ MODE = IMODE
+ IF (IMODE.GT.2) MODE = 2
+**sr 29.5. new NPOINT(1)-definition
+C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
+**
+ NHADRI = 0
+ NC = NHKK
+
+* get initial configuration
+ DO 2 I=1,NMASS
+ NHKK = NHKK+1
+ IF (JS(I).GT.0) THEN
+ ISTHKK(NHKK) = 10+MODE
+ IF (IMODE.EQ.3) THEN
+* additional treatment if HADRIN-generator is requested
+ NHADRI = NHADRI+1
+ IF (NHADRI.EQ.1) IDXTA = NHKK
+ IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
+ ENDIF
+ ELSE
+ ISTHKK(NHKK) = 12+MODE
+ ENDIF
+ IF (NMASS.GE.2) THEN
+* treatment for nuclei
+ FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
+ RR = DT_RNDM(FRAC)
+ IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
+ IDX = 8
+ NN = NN+1
+ ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
+ IDX = 1
+ NP = NP+1
+ ELSEIF (NN.LT.NNEU) THEN
+ IDX = 8
+ NN = NN+1
+ ELSEIF (NP.LT.NCH) THEN
+ IDX = 1
+ NP = NP+1
+ ENDIF
+ IDHKK(NHKK) = IDT_IPDGHA(IDX)
+ IDBAM(NHKK) = IDX
+ IF (MODE.EQ.1) THEN
+ IPOSP(I) = NHKK
+ KKPROJ(I) = IDX
+ ELSE
+ IPOST(I) = NHKK
+ KKTARG(I) = IDX
+ ENDIF
+ IF (IDX.EQ.1) THEN
+ PFER = PFERMP(MODE)
+ PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
+ ELSE
+ PFER = PFERMN(MODE)
+ PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
+ ENDIF
+ CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
+ DO 3 K=1,4
+ PFTOT(K) = PFTOT(K)+PF(K)
+ PHKK(K,NHKK) = PF(K)
+ 3 CONTINUE
+ PHKK(5,NHKK) = AAM(IDX)
+ ELSE
+* treatment for hadrons
+ IDHKK(NHKK) = IDT_IPDGHA(ID)
+ IDBAM(NHKK) = ID
+ PHKK(4,NHKK) = AAM(ID)
+ PHKK(5,NHKK) = AAM(ID)
+C* VDM assumption
+C IF (IDHKK(NHKK).EQ.22) THEN
+C PHKK(4,NHKK) = AAM(33)
+C PHKK(5,NHKK) = AAM(33)
+C ENDIF
+ IF (MODE.EQ.1) THEN
+ IPOSP(I) = NHKK
+ KKPROJ(I) = ID
+ PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
+ ELSE
+ IPOST(I) = NHKK
+ KKTARG(I) = ID
+ ENDIF
+ ENDIF
+ DO 4 K=1,3
+ VHKK(K,NHKK) = COORD(K,I)*FM2MM
+ WHKK(K,NHKK) = COORD(K,I)*FM2MM
+ 4 CONTINUE
+ IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
+ IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
+ VHKK(4,NHKK) = 0.0D0
+ WHKK(4,NHKK) = 0.0D0
+ 2 CONTINUE
+
+* balance Fermi-momenta
+ IF (NMASS.GE.2) THEN
+ DO 5 I=1,NMASS
+ NC = NC+1
+ DO 6 K=1,3
+ PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
+ 6 CONTINUE
+ PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
+ & PHKK(2,NC)**2+PHKK(3,NC)**2)
+ 5 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_FER4M.FOR
+*COPY DT_FER4M
+*
+*===fer4m==============================================================*
+*
+ SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
+
+************************************************************************
+* Sampling of nucleon Fermi-momenta from distributions at T=0. *
+* processed by S. Roesler, 17.10.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LSTART
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+ DATA LSTART /.TRUE./
+
+ ILOOP = 0
+ IF (LFERMI) THEN
+ IF (LSTART) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
+ LSTART = .FALSE.
+ ENDIF
+ 1 CONTINUE
+ CALL DT_DFERMI(PABS)
+ PABS = PFERM*PABS
+C IF (PABS.GE.PBIND) THEN
+C ILOOP = ILOOP+1
+C IF (MOD(ILOOP,500).EQ.0) THEN
+C WRITE(LOUT,1001) PABS,PBIND,ILOOP
+C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
+C & ' energy ',2E12.3,I6)
+C ENDIF
+C GOTO 1
+C ENDIF
+ CALL DT_DPOLI(POLC,POLS)
+ CALL DT_DSFECF(SFE,CFE)
+ CXTA = POLS*CFE
+ CYTA = POLS*SFE
+ CZTA = POLC
+ ET = SQRT(PABS*PABS+AAM(KT)**2)
+ PXT = CXTA*PABS
+ PYT = CYTA*PABS
+ PZT = CZTA*PABS
+ ELSE
+ ET = AAM(KT)
+ PXT = 0.0D0
+ PYT = 0.0D0
+ PZT = 0.0D0
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_NUC2CM.FOR
+*COPY DT_NUC2CM
+*
+*===nuc2cm=============================================================*
+*
+ SUBROUTINE DT_NUC2CM
+
+************************************************************************
+* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
+* nucl. cms. (This subroutine replaces NUCMOM.) *
+* This version dated 15.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+**temporary
+
+* statistics: Glauber-formalism
+ COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+**
+
+ ICWP = 0
+ ICWT = 0
+ NWTACC = 0
+ NWAACC = 0
+ NWBACC = 0
+
+ NPOINT(1) = NHKK+1
+ NEND = NHKK
+ DO 1 I=1,NEND
+ IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
+ IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
+ IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
+ MODE = ISTHKK(I)-9
+C IF (IDHKK(I).EQ.22) THEN
+C* VDM assumption
+C PEIN = AAM(33)
+C IDB = 33
+C ELSE
+C PEIN = PHKK(4,I)
+C IDB = IDBAM(I)
+C ENDIF
+C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
+C & PX,PY,PZ,PE,IDB,MODE)
+ IF (PHKK(5,I).GT.ZERO) THEN
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PX,PY,PZ,PE,IDBAM(I),MODE)
+ ELSE
+ PX = PGAMM(1)
+ PY = PGAMM(2)
+ PZ = PGAMM(3)
+ PE = PGAMM(4)
+ ENDIF
+ IST = ISTHKK(I)-2
+ ID = IDHKK(I)
+C* VDM assumption
+C IF (ID.EQ.22) ID = 113
+ CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
+ IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
+ IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
+ ENDIF
+ 1 CONTINUE
+
+ NWTACC = MAX(NWAACC,NWBACC)
+ ICDPR = ICDPR+ICWP
+ ICDTA = ICDTA+ICWT
+**temporary
+ IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
+ CALL DT_EVTOUT(4)
+ STOP
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SPLPTN.FOR
+*COPY DT_SPLPTN
+*
+*===splptn=============================================================*
+*
+ SUBROUTINE DT_SPLPTN(NN)
+
+************************************************************************
+* SamPLing of ParToN momenta and flavors. *
+* This version dated 15.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* sample flavors of sea-quarks
+ CALL DT_SPLFLA(NN,1)
+
+* sample x-values of partons at chain ends
+ ECM = UMO
+ CALL DT_XKSAMP(NN,ECM)
+
+* samle flavors
+ CALL DT_SPLFLA(NN,2)
+
+ RETURN
+ END
+
+*$ CREATE DT_SPLFLA.FOR
+*COPY DT_SPLFLA
+*
+*===splfla=============================================================*
+*
+ SUBROUTINE DT_SPLFLA(NN,MODE)
+
+************************************************************************
+* SamPLing of FLAvors of partons at chain ends. *
+* This subroutine replaces FLKSAA/FLKSAM. *
+* NN number of nucleon-nucleon interactions *
+* MODE = 1 sea-flavors *
+* = 2 valence-flavors *
+* Based on the original version written by J. Ranft/H.-J. Moehring. *
+* This version dated 16.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* flavors of partons (DTUNUC 1.x)
+ COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+ & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+ & IPSQ(MAXSQU),IPSQ2(MAXSQU),
+ & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+ & ITSQ(MAXSQU),ITSQ2(MAXSQU),
+ & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+ & KKPROJ(MAXVQU),KKTARG(MAXVQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+ & IXPV,IXPS,IXTV,IXTS,
+ & INTVV1(MAXVQU),INTVV2(MAXVQU),
+ & INTSV1(MAXVQU),INTSV2(MAXVQU),
+ & INTVS1(MAXVQU),INTVS2(MAXVQU),
+ & INTSS1(MAXSQU),INTSS2(MAXSQU),
+ & INTDV1(MAXVQU),INTDV2(MAXVQU),
+ & INTVD1(MAXVQU),INTVD2(MAXVQU),
+ & INTDS1(MAXSQU),INTDS2(MAXSQU),
+ & INTSD1(MAXSQU),INTSD2(MAXSQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+ & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ IF (MODE.EQ.1) THEN
+* sea-flavors
+ DO 1 I=1,NN
+ IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
+ IPSAQ(I) = -IPSQ(I)
+ 1 CONTINUE
+ DO 2 I=1,NN
+ ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
+ ITSAQ(I)= -ITSQ(I)
+ 2 CONTINUE
+ ELSEIF (MODE.EQ.2) THEN
+* valence flavors
+ DO 3 I=1,IXPV
+ CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
+ 3 CONTINUE
+ DO 4 I=1,IXTV
+ CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
+ 4 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_GETPTN.FOR
+*COPY DT_GETPTN
+*
+*===getptn=============================================================*
+*
+ SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
+
+************************************************************************
+* This subroutine collects partons at chain ends from temporary *
+* commons and puts them into DTEVT1. *
+* This version dated 15.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
+
+ LOGICAL LCHK
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* x-values of partons (DTUNUC 1.x)
+ COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
+ & XTVQ(MAXVQU),XTVD(MAXVQU),
+ & XPSQ(MAXSQU),XPSAQ(MAXSQU),
+ & XTSQ(MAXSQU),XTSAQ(MAXSQU)
+
+* flavors of partons (DTUNUC 1.x)
+ COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+ & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+ & IPSQ(MAXSQU),IPSQ2(MAXSQU),
+ & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+ & ITSQ(MAXSQU),ITSQ2(MAXSQU),
+ & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+ & KKPROJ(MAXVQU),KKTARG(MAXVQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+ & IXPV,IXPS,IXTV,IXTS,
+ & INTVV1(MAXVQU),INTVV2(MAXVQU),
+ & INTSV1(MAXVQU),INTSV2(MAXVQU),
+ & INTVS1(MAXVQU),INTVS2(MAXVQU),
+ & INTSS1(MAXSQU),INTSS2(MAXSQU),
+ & INTDV1(MAXVQU),INTDV2(MAXVQU),
+ & INTVD1(MAXVQU),INTVD2(MAXVQU),
+ & INTDS1(MAXSQU),INTDS2(MAXSQU),
+ & INTSD1(MAXSQU),INTSD2(MAXSQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+ & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
+
+ DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
+
+ IREJ = 0
+ NCSY = 0
+ NPOINT(2) = NHKK+1
+
+* sea-sea chains
+ DO 10 I=1,NSS
+ IF (ISKPCH(1,I).EQ.99) GOTO 10
+ ICCHAI(1,1) = ICCHAI(1,1)+2
+ IDXP = INTSS1(I)
+ IDXT = INTSS2(I)
+ MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
+ DO 11 K=1,4
+ PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+ PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
+ 11 CONTINUE
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
+C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
+ 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
+ ENDIF
+ IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+ IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+ IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+ CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,1)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,1)
+ CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,1)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,1)
+ NCSY = NCSY+1
+ 10 CONTINUE
+
+* disea-sea chains
+ DO 20 I=1,NDS
+ IF (ISKPCH(2,I).EQ.99) GOTO 20
+ ICCHAI(1,2) = ICCHAI(1,2)+2
+ IDXP = INTDS1(I)
+ IDXT = INTDS2(I)
+ MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
+ DO 21 K=1,4
+ PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+ PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+ 21 CONTINUE
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
+C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
+ 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
+ ENDIF
+ IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
+ IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
+ IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+ IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+ CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,2)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,2)
+ CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,2)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,2)
+ NCSY = NCSY+1
+ 20 CONTINUE
+
+* sea-disea chains
+ DO 30 I=1,NSD
+ IF (ISKPCH(3,I).EQ.99) GOTO 30
+ ICCHAI(1,3) = ICCHAI(1,3)+2
+ IDXP = INTSD1(I)
+ IDXT = INTSD2(I)
+ MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
+ DO 31 K=1,4
+ PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+ PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+ 31 CONTINUE
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
+C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
+ 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
+ ENDIF
+ IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+ IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
+ IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
+ CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,3)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,3)
+ CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,3)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,3)
+ NCSY = NCSY+1
+ 30 CONTINUE
+
+* disea-valence chains
+ DO 50 I=1,NDV
+ IF (ISKPCH(5,I).EQ.99) GOTO 50
+ ICCHAI(1,5) = ICCHAI(1,5)+2
+ IDXP = INTDV1(I)
+ IDXT = INTDV2(I)
+ MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
+ DO 51 K=1,4
+ PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
+ PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
+ 51 CONTINUE
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
+C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
+ 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
+ ENDIF
+ IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
+ IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
+ IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+ IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+ CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,5)
+ CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,5)
+ CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,5)
+ CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,5)
+ NCSY = NCSY+1
+ 50 CONTINUE
+
+* valence-sea chains
+ DO 60 I=1,NVS
+ IF (ISKPCH(6,I).EQ.99) GOTO 60
+ ICCHAI(1,6) = ICCHAI(1,6)+2
+ IDXP = INTVS1(I)
+ IDXT = INTVS2(I)
+ MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
+ DO 61 K=1,4
+ PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
+ PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+ PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
+ 61 CONTINUE
+ IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+ IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+ IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+ CALL DT_CHKCSY(IFP1,IFT1,LCHK)
+ IF (LCHK) THEN
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,6)
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ ELSE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,6)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,6)
+ PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+ & +(PP1(3)+PT2(3))**2)
+ ECH = PP1(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+ & +(PP2(3)+PT1(3))**2)
+ ECH = PP2(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ ENDIF
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
+C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
+ 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
+ ENDIF
+ NCSY = NCSY+1
+ 60 CONTINUE
+
+* sea-valence chains
+ DO 40 I=1,NSV
+ IF (ISKPCH(4,I).EQ.99) GOTO 40
+ ICCHAI(1,4) = ICCHAI(1,4)+2
+ IDXP = INTSV1(I)
+ IDXT = INTSV2(I)
+ MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
+ DO 41 K=1,4
+ PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
+ PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
+ 41 CONTINUE
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
+C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
+ 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
+ ENDIF
+ IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+ IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+ IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+ CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,4)
+ CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,4)
+ CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,4)
+ CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,4)
+ NCSY = NCSY+1
+ 40 CONTINUE
+
+* valence-disea chains
+ DO 70 I=1,NVD
+ IF (ISKPCH(7,I).EQ.99) GOTO 70
+ ICCHAI(1,7) = ICCHAI(1,7)+2
+ IDXP = INTVD1(I)
+ IDXT = INTVD2(I)
+ MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
+ DO 71 K=1,4
+ PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
+ PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
+ PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+ PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+ 71 CONTINUE
+ IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+ IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
+ IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
+ CALL DT_CHKCSY(IFP1,IFT1,LCHK)
+ IF (LCHK) THEN
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,7)
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ ELSE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,7)
+ CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,7)
+ PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+ & +(PP1(3)+PT2(3))**2)
+ ECH = PP1(4)+PT2(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+ & +(PP2(3)+PT1(3))**2)
+ ECH = PP2(4)+PT1(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ ENDIF
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
+C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
+ 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
+ ENDIF
+ NCSY = NCSY+1
+ 70 CONTINUE
+
+* valence-valence chains
+ DO 80 I=1,NVV
+ IF (ISKPCH(8,I).EQ.99) GOTO 80
+ ICCHAI(1,8) = ICCHAI(1,8)+2
+ IDXP = INTVV1(I)
+ IDXT = INTVV2(I)
+ MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+ MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
+ DO 81 K=1,4
+ PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
+ PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
+ PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
+ PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
+ 81 CONTINUE
+ IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+ IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+ IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+ IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+
+* check for diffractive event
+ IDIFF = 0
+ IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
+ & (IP.EQ.1).AND.(NN.EQ.1)) THEN
+ DO 800 K=1,4
+ PP(K) = PP1(K)+PP2(K)
+ PT(K) = PT1(K)+PT2(K)
+ 800 CONTINUE
+ ISTCK = NHKK
+ CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
+ & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+ IF (IREJ1.NE.0) THEN
+ IDIFF = 0
+ NHKK = ISTCK
+ ENDIF
+ ELSE
+ IDIFF = 0
+ ENDIF
+
+ IF (IDIFF.EQ.0) THEN
+* valence-valence chain system
+ CALL DT_CHKCSY(IFP1,IFT1,LCHK)
+ IF (LCHK) THEN
+* baryon-baryon
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,
+ & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
+ CALL DT_EVTPUT(-22,IFT1,MOT,0,
+ & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,
+ & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
+ CALL DT_EVTPUT(-22,IFT2,MOT,0,
+ & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ ELSE
+* antibaryon-baryon
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,
+ & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
+ CALL DT_EVTPUT(-22,IFT2,MOT,0,
+ & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,
+ & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
+ CALL DT_EVTPUT(-22,IFT1,MOT,0,
+ & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
+ PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+ & +(PP1(3)+PT2(3))**2)
+ ECH = PP1(4)+PT2(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+ & +(PP2(3)+PT1(3))**2)
+ ECH = PP2(4)+PT1(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ ENDIF
+ IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
+C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
+ 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
+ ENDIF
+ ELSE
+ WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
+ ENDIF
+ NCSY = NCSY+1
+ ENDIF
+ 80 CONTINUE
+ IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
+
+* energy-momentum & flavor conservation check
+ IF (ABS(IDIFF).NE.1) THEN
+ IF (IDIFF.NE.0) THEN
+ IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
+ & 1,3,10,IREJ)
+ ELSE
+ IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
+ & 1,3,10,IREJ)
+ ENDIF
+ IF (IREJ.NE.0) THEN
+ CALL DT_EVTOUT(4)
+ STOP
+ ENDIF
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_CHKCSY.FOR
+*COPY DT_CHKCSY
+*
+*===chkcsy=============================================================*
+*
+ SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
+
+************************************************************************
+* CHeCk Chain SYstem for consistency of partons at chain ends. *
+* ID1,ID2 PDG-numbers of partons at chain ends *
+* LCHK = .true. consistent chain *
+* = .false. inconsistent chain *
+* This version dated 18.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LCHK
+
+ LCHK = .TRUE.
+
+* q-aq chain
+ IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
+ IF (ID1*ID2.GT.0) LCHK = .FALSE.
+* q-qq, aq-aqaq chain
+ ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
+ & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
+ IF (ID1*ID2.LT.0) LCHK = .FALSE.
+* qq-aqaq chain
+ ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
+ IF (ID1*ID2.GT.0) LCHK = .FALSE.
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_EVENTA.FOR
+*COPY DT_EVENTA
+*
+*===eventa=============================================================*
+*
+ SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
+
+************************************************************************
+* Treatment of nucleon-nucleon interactions in a two-chain *
+* approximation. *
+* (input) ID BAMJET-index of projectile hadron (in case of *
+* h-K scattering) *
+* IP/IT mass number of projectile/target nucleus *
+* NCSY number of two chain systems *
+* IREJ rejection flag *
+* This version dated 15.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
+
+ IREJ = 0
+ NPOINT(3) = NHKK+1
+
+* skip following treatment for low-mass diffraction
+ IF (ABS(IFLAGD).EQ.1) THEN
+ NPOINT(3) = NPOINT(2)
+ GOTO 5
+ ENDIF
+
+* multiple scattering of chain ends
+ IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
+ IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
+
+ NC = NPOINT(2)
+* get a two-chain system from DTEVT1
+ DO 3 I=1,NCSY
+ IFP1 = IDHKK(NC)
+ IFT1 = IDHKK(NC+1)
+ IFP2 = IDHKK(NC+2)
+ IFT2 = IDHKK(NC+3)
+ DO 4 K=1,4
+ PP1(K) = PHKK(K,NC)
+ PT1(K) = PHKK(K,NC+1)
+ PP2(K) = PHKK(K,NC+2)
+ PT2(K) = PHKK(K,NC+3)
+ 4 CONTINUE
+ MOP1 = NC
+ MOT1 = NC+1
+ MOP2 = NC+2
+ MOT2 = NC+3
+ CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
+ & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IRHHA = IRHHA+1
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
+ GOTO 9999
+ ENDIF
+ NC = NC+4
+ 3 CONTINUE
+
+* meson/antibaryon projectile:
+* sample single-chain valence-valence systems (Reggeon contrib.)
+ IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
+ IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
+ ENDIF
+
+ IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+* check DTEVT1 for remaining resonance mass corrections
+ CALL DT_EVTRES(IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IRRES(1) = IRRES(1)+1
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
+ GOTO 9999
+ ENDIF
+ ENDIF
+
+* assign p_t to two-"chain" systems consisting of two resonances only
+* since only entries for chains will be affected, this is obsolete
+* in case of JETSET-fragmetation
+ CALL DT_RESPT
+
+* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
+ IF (LCO2CR) CALL DT_COM2CR
+
+ 5 CONTINUE
+
+* fragmentation of the complete event
+**uncomment for internal phojet-fragmentation
+C CALL DT_EVTFRA(IREJ1)
+ CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ IRFRAG = IRFRAG+1
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
+ GOTO 9999
+ ENDIF
+
+* decay of possible resonances (should be obsolete)
+ CALL DT_DECAY1
+
+ RETURN
+
+ 9999 CONTINUE
+ IREVT = IREVT+1
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_GETCSY.FOR
+*COPY DT_GETCSY
+*
+*===getcsy=============================================================*
+*
+ SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
+ & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
+
+************************************************************************
+* This version dated 15.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
+ & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
+
+ IREJ = 0
+
+* get quark content of partons
+ DO 1 I=1,2
+ IFP1(I) = 0
+ IFP2(I) = 0
+ IFT1(I) = 0
+ IFT2(I) = 0
+ 1 CONTINUE
+ IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
+ IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
+ IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
+ IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
+ IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
+ IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
+ IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
+ IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
+
+* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
+ IDCH1 = 2
+ IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
+ IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
+ IDCH2 = 2
+ IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
+ IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
+
+* store initial configuration for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
+
+* sample intrinsic p_t at chain-ends
+ CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
+ & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
+ & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
+ IRPT = IRPT+1
+ GOTO 9999
+ ENDIF
+
+C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
+C* check second chain for resonance
+C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+C & AMCH2,AMCH2N,IDCH2,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C IF (IDR2.NE.0) THEN
+C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+C & AMCH2,AMCH2N,AMCH1,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C ENDIF
+C* check first chain for resonance
+C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+C & AMCH1,AMCH1N,IDCH1,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C IF (IDR1.NE.0) IDR1 = 100*IDR1
+C ELSE
+C* check first chain for resonance
+C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+C & AMCH1,AMCH1N,IDCH1,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C IF (IDR1.NE.0) THEN
+C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+C & AMCH1,AMCH1N,AMCH2,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C ENDIF
+C* check second chain for resonance
+C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+C & AMCH2,AMCH2N,IDCH2,IREJ1)
+C IF (IREJ1.NE.0) GOTO 9999
+C IF (IDR2.NE.0) IDR2 = 100*IDR2
+C ENDIF
+C ENDIF
+
+ IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+* check chains for resonances
+ CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+ & AMCH1,AMCH1N,IDCH1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+ & AMCH2,AMCH2N,IDCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+* change kinematics corresponding to resonance-masses
+ IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
+ CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
+ CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+ & AMCH2,AMCH2N,IDCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (IDR2.NE.0) IDR2 = 100*IDR2
+ ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
+ CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+ & AMCH2,AMCH2N,AMCH1,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
+ CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+ & AMCH1,AMCH1N,IDCH1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (IDR1.NE.0) IDR1 = 100*IDR1
+ ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
+ AMDIF1 = ABS(AMCH1-AMCH1N)
+ AMDIF2 = ABS(AMCH2-AMCH2N)
+ IF (AMDIF2.LT.AMDIF1) THEN
+ CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+ & AMCH2,AMCH2N,AMCH1,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
+ CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
+ & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (IDR1.NE.0) IDR1 = 100*IDR1
+ ELSE
+ CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
+ CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
+ & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (IDR2.NE.0) IDR2 = 100*IDR2
+ ENDIF
+ ENDIF
+ ENDIF
+
+* store final configuration for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+* put partons and chains into DTEVT1
+ DO 10 I=1,4
+ PCH1(I) = PP1(I)+PT1(I)
+ PCH2(I) = PP2(I)+PT2(I)
+ 10 CONTINUE
+ CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
+ & PP1(3),PP1(4),0,0,0)
+ CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
+ & PT1(3),PT1(4),0,0,0)
+ KCH = 100+IDCH(MOP1)*10+1
+ CALL DT_EVTPUT(KCH,88888,-2,-1,
+ & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
+ CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
+ & PP2(3),PP2(4),0,0,0)
+ CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
+ & PT2(3),PT2(4),0,0,0)
+ KCH = KCH+1
+ CALL DT_EVTPUT(KCH,88888,-2,-1,
+ & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
+
+ RETURN
+
+ 9999 CONTINUE
+ IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
+* "cancel" sea-sea chains
+ CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9998
+**sr 16.5. flag for EVENTB
+ IREJ = -1
+ RETURN
+ ENDIF
+ 9998 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_CHKINE.FOR
+*COPY DT_CHKINE
+*
+*===chkine=============================================================*
+*
+ SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
+ & AMCH1,AMCH1N,AMCH2,IREJ)
+
+************************************************************************
+* This subroutine replaces CORMOM. *
+* This version dated 05.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
+ & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
+
+ IREJ = 0
+ JMSHL = IMSHL
+
+ SCALE = AMCH1N/MAX(AMCH1,TINY10)
+ DO 10 I=1,4
+ PP1(I) = PP1I(I)
+ PP2(I) = PP2I(I)
+ PT1(I) = PT1I(I)
+ PT2(I) = PT2I(I)
+ PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
+ PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
+ PP1(I) = SCALE*PP1(I)
+ PT1(I) = SCALE*PT1(I)
+ 10 CONTINUE
+ IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
+ & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
+
+ ECH = PP2(4)+PT2(4)
+ PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
+ & (PP2(3)+PT2(3))**2 )
+ AMCH22 = (ECH-PCH)*(ECH+PCH)
+ IF (AMCH22.LT.0.0D0) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
+ GOTO 9997
+ ENDIF
+
+ AMCH1 = AMCH1N
+ AMCH2 = SQRT(AMCH22)
+
+* put partons again on mass shell
+ 13 CONTINUE
+ XM1 = 0.0D0
+ XM2 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFP1)
+ XM2 = PYMASS(IFT1)
+
+ ENDIF
+ CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (JMSHL.EQ.0) GOTO 9998
+ JMSHL = 0
+ GOTO 13
+ ENDIF
+ JMSHL = IMSHL
+ DO 11 I=1,4
+ PP1(I) = P1(I)
+ PT1(I) = P2(I)
+ 11 CONTINUE
+ 14 CONTINUE
+ XM1 = 0.0D0
+ XM2 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFP2)
+ XM2 = PYMASS(IFT2)
+
+ ENDIF
+ CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (JMSHL.EQ.0) GOTO 9998
+ JMSHL = 0
+ GOTO 14
+ ENDIF
+ DO 12 I=1,4
+ PP2(I) = P1(I)
+ PT2(I) = P2(I)
+ 12 CONTINUE
+ DO 15 I=1,4
+ PP1I(I) = PP1(I)
+ PP2I(I) = PP2(I)
+ PT1I(I) = PT1(I)
+ PT2I(I) = PT2(I)
+ 15 CONTINUE
+ RETURN
+
+ 9997 IRCHKI(1) = IRCHKI(1)+1
+**sr
+C GOTO 9999
+ IREJ = -1
+ RETURN
+**
+ 9998 IRCHKI(2) = IRCHKI(2)+1
+
+ 9999 CONTINUE
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_CH2RES.FOR
+*COPY DT_CH2RES
+*
+*===ch2res=============================================================*
+*
+ SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
+ & AM,AMN,IMODE,IREJ)
+
+************************************************************************
+* Check chains for resonance production. *
+* This subroutine replaces COMCMA/COBCMA/COMCM2 *
+* input: *
+* IF1,2,3,4 input flavors (q,aq in any order) *
+* AM chain mass *
+* MODE = 1 check q-aq chain for meson-resonance *
+* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
+* = 3 check qq-aqaq chain for lower mass cut *
+* output: *
+* IDR = 0 no resonances found *
+* = -1 pseudoscalar meson/octet baryon *
+* = 1 vector-meson/decuplet baryon *
+* IDXR BAMJET-index of corresponding resonance *
+* AMN mass of corresponding resonance *
+* *
+* IREJ rejection flag *
+* This version dated 06.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* quark-content to particle index conversion (DTUNUC 1.x)
+ COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
+ & IA08(6,21),IA10(6,21)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ DIMENSION IF(4),JF(4)
+
+**sr 4.7. test
+C DATA AMLOM,AMLOB /0.08D0,0.2D0/
+ DATA AMLOM,AMLOB /0.1D0,0.7D0/
+**
+C DATA AMLOM,AMLOB /0.001D0,0.001D0/
+
+ MODE = ABS(IMODE)
+
+ IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
+ WRITE(LOUT,1000) MODE
+ 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
+ & 1X,' program stopped')
+ STOP
+ ENDIF
+
+ AMX = AM
+ IREJ = 0
+ IDR = 0
+ IDXR = 0
+ AMN = AMX
+ IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
+ IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
+
+ IF(1) = IF1
+ IF(2) = IF2
+ IF(3) = IF3
+ IF(4) = IF4
+ NF = 0
+ DO 100 I=1,4
+ IF (IF(I).NE.0) THEN
+ NF = NF+1
+ JF(NF) = IF(I)
+ ENDIF
+ 100 CONTINUE
+ IF (NF.LE.MODE) THEN
+ WRITE(LOUT,1001) MODE,IF
+ 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
+ & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
+ GOTO 9999
+ ENDIF
+
+ GOTO (1,2,3) MODE
+
+* check for meson resonance
+ 1 CONTINUE
+ IFQ = JF(1)
+ IFAQ = ABS(JF(2))
+ IF (JF(2).GT.0) THEN
+ IFQ = JF(2)
+ IFAQ = ABS(JF(1))
+ ENDIF
+ IFPS = IMPS(IFAQ,IFQ)
+ IFV = IMVE(IFAQ,IFQ)
+ AMPS = AAM(IFPS)
+ AMV = AAM(IFV)
+ AMHI = AMV+0.3D0
+ IF (AMX.LT.AMV) THEN
+ IF (AMX.LT.AMPS) THEN
+ IF (IMODE.GT.0) THEN
+ IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
+ ELSE
+ IF (AMX.LT.0.8D0*AMPS) GOTO 9999
+ ENDIF
+ LOMRES = LOMRES+1
+ ENDIF
+* replace chain by pseudoscalar meson
+ IDR = -1
+ IDXR = IFPS
+ AMN = AMPS
+ ELSEIF (AMX.LT.AMHI) THEN
+* replace chain by vector-meson
+ IDR = 1
+ IDXR = IFV
+ AMN = AMV
+ ENDIF
+ RETURN
+
+* check for baryon resonance
+ 2 CONTINUE
+ CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
+ AM8 = AAM(JB8)
+ AM10 = AAM(JB10)
+ AMHI = AM10+0.3D0
+ IF (AMX.LT.AM10) THEN
+ IF (AMX.LT.AM8) THEN
+ IF (IMODE.GT.0) THEN
+ IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
+ ELSE
+ IF (AMX.LT.0.8D0*AM8) GOTO 9999
+ ENDIF
+ LOBRES = LOBRES+1
+ ENDIF
+* replace chain by oktet baryon
+ IDR = -1
+ IDXR = JB8
+ AMN = AM8
+ ELSEIF (AMX.LT.AMHI) THEN
+ IDR = 1
+ IDXR = JB10
+ AMN = AM10
+ ENDIF
+ RETURN
+
+* check qq-aqaq for lower mass cut
+ 3 CONTINUE
+* empirical definition of AMHI to allow for (b-antib)-pair prod.
+ AMHI = 2.5D0
+ IF (AMX.LT.AMHI) GOTO 9999
+ RETURN
+
+ 9999 CONTINUE
+ IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
+ & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
+ IREJ = 1
+ IRRES(2) = IRRES(2)+1
+ RETURN
+ END
+
+*$ CREATE DT_RJSEAC.FOR
+*COPY DT_RJSEAC
+*
+*===rjseac=============================================================*
+*
+ SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
+
+************************************************************************
+* ReJection of SEA-sea Chains. *
+* MOP1/2 entries of projectile sea-partons in DTEVT1 *
+* MOT1/2 entries of projectile sea-partons in DTEVT1 *
+* This version dated 16.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+ DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
+
+ IREJ = 0
+
+* projectile sea q-aq-pair
+* indices of sea-pair
+ IDXSEA(1,1) = MOP1
+ IDXSEA(1,2) = MOP2
+* index of mother-nucleon
+ IDXNUC(1) = JMOHKK(1,MOP1)
+* status of valence quarks to be corrected
+ ISTVAL(1) = -21
+
+* target sea q-aq-pair
+* indices of sea-pair
+ IDXSEA(2,1) = MOT1
+ IDXSEA(2,2) = MOT2
+* index of mother-nucleon
+ IDXNUC(2) = JMOHKK(1,MOT1)
+* status of valence quarks to be corrected
+ ISTVAL(2) = -22
+
+ DO 1 N=1,2
+ IDONE = 0
+ DO 2 I=NPOINT(2),NHKK
+ IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
+ & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
+* valence parton found
+* inrease 4-momentum by sea 4-momentum
+ DO 3 K=1,4
+ PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
+ & PHKK(K,IDXSEA(N,2))
+ 3 CONTINUE
+ PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+ & PHKK(2,I)**2-PHKK(3,I)**2))
+* "cancel" sea-pair
+ DO 4 J=1,2
+ ISTHKK(IDXSEA(N,J)) = 100
+ IDHKK(IDXSEA(N,J)) = 0
+ JMOHKK(1,IDXSEA(N,J)) = 0
+ JMOHKK(2,IDXSEA(N,J)) = 0
+ JDAHKK(1,IDXSEA(N,J)) = 0
+ JDAHKK(2,IDXSEA(N,J)) = 0
+ DO 5 K=1,4
+ PHKK(K,IDXSEA(N,J)) = ZERO
+ VHKK(K,IDXSEA(N,J)) = ZERO
+ WHKK(K,IDXSEA(N,J)) = ZERO
+ 5 CONTINUE
+ PHKK(5,IDXSEA(N,J)) = ZERO
+ 4 CONTINUE
+ IDONE = 1
+ ENDIF
+ 2 CONTINUE
+ IF (IDONE.NE.1) THEN
+ WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
+ 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
+ & '-record!',/,1X,' sea-quark pairs ',
+ & 2I5,4X,2I5,' could not be canceled!')
+ GOTO 9999
+ ENDIF
+ 1 CONTINUE
+ ICRJSS = ICRJSS+1
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_VV2SCH.FOR
+*COPY DT_VV2SCH
+*
+*===vv2sch=============================================================*
+*
+ SUBROUTINE DT_VV2SCH
+
+************************************************************************
+* Change Valence-Valence chain systems to Single CHain systems for *
+* hadron-nucleus collisions with meson or antibaryon projectile. *
+* (Reggeon contribution) *
+* The single chain system is approximately treated as one chain and a *
+* meson at rest. *
+* This version dated 18.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
+
+ LOGICAL LSTART
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+ DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
+ & PCH2(4)
+
+ DATA LSTART /.TRUE./
+
+ IFSC = 0
+ IF (LSTART) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
+ & 'valence chains treated')
+ LSTART = .FALSE.
+ ENDIF
+
+ NSTOP = NHKK
+
+* get index of first chain
+ DO 1 I=NPOINT(3),NHKK
+ IF (IDHKK(I).EQ.88888) THEN
+ NC = I
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+
+ 2 CONTINUE
+ IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
+ & .AND.(NC.LT.NSTOP)) THEN
+* get valence-valence chains
+ IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
+* get "mother"-hadron indices
+ MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
+ MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
+ KPROJ = IDT_ICIHAD(IDHKK(MO1))
+ KTARG = IDT_ICIHAD(IDHKK(MO2))
+* Lab momentum of projectile hadron
+ CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
+ PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
+ & PHKK(3,MO1)**2)
+
+ SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
+ IF (DT_RNDM(PTOT).LE.SICHAP) THEN
+ ICVV2S = ICVV2S+1
+* single chain requested
+* get flavors of chain-end partons
+ MO(1) = JMOHKK(1,NC)
+ MO(2) = JMOHKK(2,NC)
+ MO(3) = JMOHKK(1,NC+3)
+ MO(4) = JMOHKK(2,NC+3)
+ DO 3 I=1,4
+ IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
+ IF(I,2) = 0
+ IF (ABS(IDHKK(MO(I))).GE.1000)
+ & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
+ 3 CONTINUE
+* which one is the q-aq chain?
+* N1,N1+1 - DTEVT1-entries for q-aq system
+* N2,N2+1 - DTEVT1-entries for the other chain
+ IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
+ K1 = 1
+ K2 = 3
+ N1 = NC-2
+ N2 = NC+1
+ ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
+ K1 = 3
+ K2 = 1
+ N1 = NC+1
+ N2 = NC-2
+ ELSE
+ GOTO 10
+ ENDIF
+ DO 4 K=1,4
+ PP1(K) = PHKK(K,N1)
+ PT1(K) = PHKK(K,N1+1)
+ PP2(K) = PHKK(K,N2)
+ PT2(K) = PHKK(K,N2+1)
+ 4 CONTINUE
+ AMCH1 = PHKK(5,N1+2)
+ AMCH2 = PHKK(5,N2+2)
+* get meson-identity corresponding to flavors of q-aq chain
+ ITMP = IRESRJ
+ IRESRJ = 0
+ CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
+ & ZERO,AMCH1N,1,IDUM)
+ IRESRJ = ITMP
+* change kinematics of chains
+ CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
+ & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 10
+* check second chain for resonance
+ IDCHAI = 2
+ IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
+ CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
+ & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
+ IF (IREJ1.NE.0) GOTO 10
+ IF (IDR2.NE.0) IDR2 = 100*IDR2
+* add partons and chains to DTEVT1
+ DO 5 K=1,4
+ PCH1(K) = PP1(K)+PT1(K)
+ PCH2(K) = PP2(K)+PT2(K)
+ 5 CONTINUE
+ CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
+ & PP1(3),PP1(4),0,0,0)
+ CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
+ & PT1(2),PT1(3),PT1(4),0,0,0)
+ KCH = ISTHKK(N1+2)+100
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
+ & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
+ IDHKK(N1+2) = 22222
+ CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
+ & PP2(3),PP2(4),0,0,0)
+ CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
+ & PT2(2),PT2(3),PT2(4),0,0,0)
+ KCH = ISTHKK(N2+2)+100
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
+ & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
+ IDHKK(N2+2) = 22222
+ ENDIF
+ ENDIF
+ ELSE
+ GOTO 11
+ ENDIF
+ 10 CONTINUE
+ NC = NC+6
+ GOTO 2
+
+ 11 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_PHNSCH.FOR
+*COPY DT_PHNSCH
+*
+*=== phnsch ===========================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
+
+*----------------------------------------------------------------------*
+* *
+* Probability for Hadron Nucleon Single CHain interactions: *
+* *
+* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-jan-94 by Alfredo Ferrari *
+* *
+* modified by J.R.for use in DTUNUC 6.1.94 *
+* *
+* Input variables: *
+* Kp = hadron projectile index (Part numbering *
+* scheme) *
+* Ktarg = target nucleon index (1=proton, 8=neutron) *
+* Plab = projectile laboratory momentum (GeV/c) *
+* Output variable: *
+* Phnsch = probability per single chain (particle *
+* exchange) interactions *
+* *
+*----------------------------------------------------------------------*
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LUNOUT = 6 )
+ PARAMETER ( LUNERR = 6 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( ZERZER = 0.D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( FIVFIV = 5.D+00 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+
+ PARAMETER ( NALLWP = 39 )
+ PARAMETER ( IDMAXP = 210 )
+
+ DIMENSION ICHRGE(39),AM(39)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION KPTOIP(210)
+
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+
+ DIMENSION SGTCOE (5,33), IHLP (NALLWP)
+ DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
+ EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
+ EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
+ EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
+
+* Conversion from part to paprop numbering
+ DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
+ & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
+
+* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
+ DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
+ & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
+ DATA SGTCO1 /
+* 1st reaction: gamma p total
+ &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
+* 2nd reaction: gamma d total
+ &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
+* 3rd reaction: pi+ p total
+ &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
+* 4th reaction: pi- p total
+ &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
+* 5th reaction: pi+/- d total
+ &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
+* 6th reaction: K+ p total
+ &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
+* 7th reaction: K+ n total
+ &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
+* 8th reaction: K+ d total
+ &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
+* 9th reaction: K- p total
+ &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
+* 10th reaction: K- n total
+ &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
+ DATA SGTCO2 /
+* 11th reaction: K- d total
+ &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
+* 12th reaction: p p total
+ &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
+* 13th reaction: p n total
+ &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
+* 14th reaction: p d total
+ &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
+* 15th reaction: pbar p total
+ &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
+* 16th reaction: pbar n total
+ &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
+* 17th reaction: pbar d total
+ &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
+* 18th reaction: Lamda p total
+ &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
+ DATA SGTCO3 /
+* 19th reaction: pi+ p elastic
+ &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
+* 20th reaction: pi- p elastic
+ &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
+* 21st reaction: K+ p elastic
+ &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
+* 22nd reaction: K- p elastic
+ &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
+* 23rd reaction: p p elastic
+ &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
+* 24th reaction: p d elastic
+ &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
+* 25th reaction: pbar p elastic
+ &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
+* 26th reaction: pbar p elastic bis
+ &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
+* 27th reaction: pbar n elastic
+ &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
+* 28th reaction: Lamda p elastic
+ &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
+* 29th reaction: K- p ela bis
+ &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
+* 30th reaction: pi- p cx
+ &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
+* 31st reaction: K- p cx
+ &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
+* 32nd reaction: K+ n cx
+ &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
+* 33rd reaction: pbar p cx
+ &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
+*
+* +-------------------------------------------------------------------*
+ ICHRGE(KTARG)=IICH(KTARG)
+ AM (KTARG)=AAM (KTARG)
+* | Check for pi0 (d-dbar)
+ IF ( KP .NE. 26 ) THEN
+ IP = KPTOIP (KP)
+ IF(IP.EQ.0)IP=1
+ ICHRGE(IP)=IICH(KP)
+ AM (IP)=AAM (KP)
+* |
+* +-------------------------------------------------------------------*
+* |
+ ELSE
+ IP = 23
+ ICHRGE(IP)=0
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | No such interactions for baryon-baryon
+ IF ( IIBAR (KP) .GT. 0 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for K+ p/n
+ ELSE IF ( IP .EQ. 15 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for K0 p/n
+ ELSE IF ( IP .EQ. 24 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for Omebar p/n
+ ELSE IF ( IP .GE. 38 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | If the momentum is larger than 50 GeV/c, compute the single
+* | chain probability at 50 GeV/c and extrapolate to the present
+* | momentum according to 1/sqrt(s)
+* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
+* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
+* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
+* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
+* | x sqrt(s/s(50))
+* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
+ IF ( PLAB .GT. 50.D+00 ) THEN
+ PLA = 50.D+00
+ AMPSQ = AM (IP)**2
+ AMTSQ = AM (KTARG)**2
+ EPROJ = SQRT ( PLAB**2 + AMPSQ )
+ UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ EPROJ = SQRT ( PLA**2 + AMPSQ )
+ UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ UMORAT = SQRT ( UMOSQ / UMO50 )
+* |
+* +-------------------------------------------------------------------*
+* | P < 3 GeV/c
+ ELSE IF ( PLAB .LT. 3.D+00 ) THEN
+ PLA = 3.D+00
+ AMPSQ = AM (IP)**2
+ AMTSQ = AM (KTARG)**2
+ EPROJ = SQRT ( PLAB**2 + AMPSQ )
+ UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ EPROJ = SQRT ( PLA**2 + AMPSQ )
+ UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ UMORAT = SQRT ( UMOSQ / UMO50 )
+* |
+* +-------------------------------------------------------------------*
+* | P < 50 GeV/c
+ ELSE
+ PLA = PLAB
+ UMORAT = ONEONE
+ END IF
+* |
+* +-------------------------------------------------------------------*
+ ALGPLA = LOG (PLA)
+* +-------------------------------------------------------------------*
+* | Pions:
+ IF ( IHLP (IP) .EQ. 2 ) THEN
+ ACOF = SGTCOE (1,3)
+ BCOF = SGTCOE (2,3)
+ ENNE = SGTCOE (3,3)
+ CCOF = SGTCOE (4,3)
+ DCOF = SGTCOE (5,3)
+* | Compute the pi+ p total cross section:
+ SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,19)
+ BCOF = SGTCOE (2,19)
+ ENNE = SGTCOE (3,19)
+ CCOF = SGTCOE (4,19)
+ DCOF = SGTCOE (5,19)
+* | Compute the pi+ p elastic cross section:
+ SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pi+ p inelastic cross section:
+ SPPPIN = SPPPTT - SPPPEL
+ ACOF = SGTCOE (1,4)
+ BCOF = SGTCOE (2,4)
+ ENNE = SGTCOE (3,4)
+ CCOF = SGTCOE (4,4)
+ DCOF = SGTCOE (5,4)
+* | Compute the pi- p total cross section:
+ SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,20)
+ BCOF = SGTCOE (2,20)
+ ENNE = SGTCOE (3,20)
+ CCOF = SGTCOE (4,20)
+ DCOF = SGTCOE (5,20)
+* | Compute the pi- p elastic cross section:
+ SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pi- p inelastic cross section:
+ SPMPIN = SPMPTT - SPMPEL
+ SIGDIA = SPMPIN - SPPPIN
+* | +----------------------------------------------------------------*
+* | | Charged pions: besides isospin consideration it is supposed
+* | | that (pi+ n)el is almost equal to (pi- p)el
+* | | and (pi+ p)el " " " " (pi- n)el
+* | | and all are almost equal among each others
+* | | (reasonable above 5 GeV/c)
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ KHELP = KTARG / 8
+ JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | | Compute the elastic cross section:
+ SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+* | | Number of diagrams:
+ NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 1 + IP - 13
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 1 + IP - 13
+* | |
+* | +----------------------------------------------------------------*
+* | | pi0: besides isospin consideration it is supposed that the
+* | | elastic cross section is not very different from
+* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
+ ELSE
+ KHELP = KTARG / 8
+ K2HLP = ( KP - 23 ) / 3
+* | | Number of diagrams:
+* | | For u ubar (k2hlp=0):
+* NDIAGR = 2 - KHELP
+* | | For d dbar (k2hlp=1):
+* NDIAGR = 2 + KHELP - K2HLP
+ NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
+ SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 1 + K2HLP
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 2 - K2HLP
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* | end pi's
+* +-------------------------------------------------------------------*
+* | Kaons:
+ ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
+ ACOF = SGTCOE (1,6)
+ BCOF = SGTCOE (2,6)
+ ENNE = SGTCOE (3,6)
+ CCOF = SGTCOE (4,6)
+ DCOF = SGTCOE (5,6)
+* | Compute the K+ p total cross section:
+ SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,21)
+ BCOF = SGTCOE (2,21)
+ ENNE = SGTCOE (3,21)
+ CCOF = SGTCOE (4,21)
+ DCOF = SGTCOE (5,21)
+* | Compute the K+ p elastic cross section:
+ SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K+ p inelastic cross section:
+ SKPPIN = SKPPTT - SKPPEL
+ ACOF = SGTCOE (1,9)
+ BCOF = SGTCOE (2,9)
+ ENNE = SGTCOE (3,9)
+ CCOF = SGTCOE (4,9)
+ DCOF = SGTCOE (5,9)
+* | Compute the K- p total cross section:
+ SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,22)
+ BCOF = SGTCOE (2,22)
+ ENNE = SGTCOE (3,22)
+ CCOF = SGTCOE (4,22)
+ DCOF = SGTCOE (5,22)
+* | Compute the K- p elastic cross section:
+ SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K- p inelastic cross section:
+ SKMPIN = SKMPTT - SKMPEL
+ SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
+* | +----------------------------------------------------------------*
+* | | Charged Kaons: actually only K-
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ KHELP = KTARG / 8
+* | | +-------------------------------------------------------------*
+* | | | Proton target:
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SKMPIN
+* | | | Number of diagrams:
+ NDIAGR = 2
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: besides isospin consideration it is supposed
+* | | | that (K- n)el is almost equal to (K- p)el
+* | | | (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,10)
+ BCOF = SGTCOE (2,10)
+ ENNE = SGTCOE (3,10)
+ CCOF = SGTCOE (4,10)
+ DCOF = SGTCOE (5,10)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SKMPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+* | | | Number of diagrams:
+ NDIAGR = 1
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 3
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 2
+* | |
+* | +----------------------------------------------------------------*
+* | | K0's: (actually only K0bar)
+ ELSE
+ KHELP = KTARG / 8
+* | | +-------------------------------------------------------------*
+* | | | Proton target: (K0bar p)in supposed to be given by
+* | | | (K- p)in - Sig_diagr
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SKMPIN - SIGDIA
+* | | | Number of diagrams:
+ NDIAGR = 1
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: (K0bar n)in supposed to be given by
+* | | | (K- n)in + Sig_diagr
+* | | | besides isospin consideration it is supposed
+* | | | that (K- n)el is almost equal to (K- p)el
+* | | | (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,10)
+ BCOF = SGTCOE (2,10)
+ ENNE = SGTCOE (3,10)
+ CCOF = SGTCOE (4,10)
+ DCOF = SGTCOE (5,10)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SKMPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL + SIGDIA
+* | | | Number of diagrams:
+ NDIAGR = 2
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 3
+ IQFSC2 = 0
+ IQBSC1 = 1
+ IQBSC2 = 1 + KHELP
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* | end Kaon's
+* +-------------------------------------------------------------------*
+* | Antinucleons:
+ ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
+* | For momenta between 3 and 5 GeV/c the use of tabulated data
+* | should be implemented!
+ ACOF = SGTCOE (1,15)
+ BCOF = SGTCOE (2,15)
+ ENNE = SGTCOE (3,15)
+ CCOF = SGTCOE (4,15)
+ DCOF = SGTCOE (5,15)
+* | Compute the pbar p total cross section:
+ SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ IF ( PLA .LT. FIVFIV ) THEN
+ JREAC = 26
+ ELSE
+ JREAC = 25
+ END IF
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | Compute the pbar p elastic cross section:
+ SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pbar p inelastic cross section:
+ SAPPIN = SAPPTT - SAPPEL
+ ACOF = SGTCOE (1,12)
+ BCOF = SGTCOE (2,12)
+ ENNE = SGTCOE (3,12)
+ CCOF = SGTCOE (4,12)
+ DCOF = SGTCOE (5,12)
+* | Compute the p p total cross section:
+ SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,23)
+ BCOF = SGTCOE (2,23)
+ ENNE = SGTCOE (3,23)
+ CCOF = SGTCOE (4,23)
+ DCOF = SGTCOE (5,23)
+* | Compute the p p elastic cross section:
+ SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K- p inelastic cross section:
+ SPPINE = SPPTOT - SPPELA
+ SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
+ KHELP = KTARG / 8
+* | +----------------------------------------------------------------*
+* | | Pbar:
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ NDIAGR = 5 - KHELP
+* | | +-------------------------------------------------------------*
+* | | | Proton target:
+ IF ( KHELP .EQ. 0 ) THEN
+* | | | Number of diagrams:
+ SHNCIN = SAPPIN
+ PUUBAR = 0.8D+00
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: it is supposed that (ap n)el is almost equal
+* | | | to (ap p)el (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,16)
+ BCOF = SGTCOE (2,16)
+ ENNE = SGTCOE (3,16)
+ CCOF = SGTCOE (4,16)
+ DCOF = SGTCOE (5,16)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SAPPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+ PUUBAR = HLFHLF
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+* | | there are different possibilities, make a random choiche:
+ IQFSC1 = -1
+ RNCHEN = DT_RNDM(PUUBAR)
+ IF ( RNCHEN .LT. PUUBAR ) THEN
+ IQFSC2 = -2
+ ELSE
+ IQFSC2 = -1
+ END IF
+ IQBSC1 = -IQFSC1 + KHELP
+ IQBSC2 = -IQFSC2
+* | |
+* | +----------------------------------------------------------------*
+* | | nbar:
+ ELSE
+ NDIAGR = 4 + KHELP
+* | | +-------------------------------------------------------------*
+* | | | Proton target: (nbar p)in supposed to be given by
+* | | | (pbar p)in - Sig_diagr
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SAPPIN - SIGDIA
+ PDDBAR = HLFHLF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: (nbar n)el is supposed to be equal to
+* | | | (pbar p)el (reasonable above 5 GeV/c)
+ ELSE
+* | | | Compute the total cross section:
+ SHNCTT = SAPPTT
+* | | | Compute the elastic cross section:
+ SHNCEL = SAPPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+ PDDBAR = 0.8D+00
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+* | | there are different possibilities, make a random choiche:
+ IQFSC1 = -2
+ RNCHEN = DT_RNDM(RNCHEN)
+ IF ( RNCHEN .LT. PDDBAR ) THEN
+ IQFSC2 = -1
+ ELSE
+ IQFSC2 = -2
+ END IF
+ IQBSC1 = -IQFSC1 + KHELP - 1
+ IQBSC2 = -IQFSC2
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* |
+* +-------------------------------------------------------------------*
+* | Others: not yet implemented
+ ELSE
+ SIGDIA = ZERZER
+ SHNCIN = ONEONE
+ NDIAGR = 0
+ DT_PHNSCH = ZERZER
+ RETURN
+ END IF
+* | end others
+* +-------------------------------------------------------------------*
+ DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
+ IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
+ & + IQECHR (IQBSC2)
+ IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
+ & + IQBCHR (IQBSC2)
+ IQECHC = IQECHC / 3
+ IQBCHC = IQBCHC / 3
+ IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
+ & + IQSCHR (IQBSC2)
+ IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
+ & + IQSCHR (MQUARK(3,IP))
+* +-------------------------------------------------------------------*
+* | Consistency check:
+ IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
+ WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
+ & DT_PHNSCH,KP,KTARG,PLA,' ****'
+ WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
+ & DT_PHNSCH,KP,KTARG,PLA,' ****'
+ DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
+ DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | Consistency check:
+ IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
+ & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
+ WRITE (LUNOUT,*)
+ &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
+ & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
+ WRITE (LUNERR,*)
+ &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
+ & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
+ IF ( UMORAT .GT. ONEPLS )
+ & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
+ & - ONEONE ) * UMORAT + ONEONE )
+ RETURN
+*
+ ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
+ DT_SCHQUA = ONEONE
+ JQFSC1 = IQFSC1
+ JQFSC2 = IQFSC2
+ JQBSC1 = IQBSC1
+ JQBSC2 = IQBSC2
+*=== End of function Phnsch ===========================================*
+ RETURN
+ END
+
+*$ CREATE DT_RESPT.FOR
+*COPY DT_RESPT
+*
+*===respt==============================================================*
+*
+ SUBROUTINE DT_RESPT
+
+************************************************************************
+* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
+* This version dated 18.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* get index of first chain
+ DO 1 I=NPOINT(3),NHKK
+ IF (IDHKK(I).EQ.88888) THEN
+ NC = I
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+
+ 2 CONTINUE
+ IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
+C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
+* skip VV-,SS- systems
+ IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
+ & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
+* check if both "chains" are resonances
+ IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
+ CALL DT_SAPTRE(NC,NC+3)
+ ENDIF
+ ENDIF
+ ELSE
+ GOTO 3
+ ENDIF
+ NC = NC+6
+ GOTO 2
+
+ 3 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_EVTRES.FOR
+*COPY DT_EVTRES
+*
+*===evtres=============================================================*
+*
+ SUBROUTINE DT_EVTRES(IREJ)
+
+************************************************************************
+* This version dated 14.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
+
+ IREJ = 0
+
+ DO 1 I=NPOINT(3),NHKK
+ IF (ABS(IDRES(I)).GE.100) THEN
+ AMMX = 0.0D0
+ DO 2 J=NPOINT(3),NHKK
+ IF (IDHKK(J).EQ.88888) THEN
+ IF (PHKK(5,J).GT.AMMX) THEN
+ AMMX = PHKK(5,J)
+ IMMX = J
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ IF (IDRES(IMMX).NE.0) THEN
+ IF (IOULEV(3).GT.0) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'EVTRES: no chain for correc. found'
+C GOTO 6
+ GOTO 9999
+ ELSE
+ GOTO 9999
+ ENDIF
+ ENDIF
+ IMO11 = JMOHKK(1,I)
+ IMO12 = JMOHKK(2,I)
+ IF (PHKK(3,IMO11).LT.0.0D0) THEN
+ IMO11 = JMOHKK(2,I)
+ IMO12 = JMOHKK(1,I)
+ ENDIF
+ IMO21 = JMOHKK(1,IMMX)
+ IMO22 = JMOHKK(2,IMMX)
+ IF (PHKK(3,IMO21).LT.0.0D0) THEN
+ IMO21 = JMOHKK(2,IMMX)
+ IMO22 = JMOHKK(1,IMMX)
+ ENDIF
+ AMCH1 = PHKK(5,I)
+ AMCH1N = AAM(IDXRES(I))
+
+ IFPR1 = IDHKK(IMO11)
+ IFPR2 = IDHKK(IMO21)
+ IFTA1 = IDHKK(IMO12)
+ IFTA2 = IDHKK(IMO22)
+ DO 4 J=1,4
+ PP1(J) = PHKK(J,IMO11)
+ PP2(J) = PHKK(J,IMO21)
+ PT1(J) = PHKK(J,IMO12)
+ PT2(J) = PHKK(J,IMO22)
+ 4 CONTINUE
+* store initial configuration for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
+* correct kinematics of second chain
+ CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+* check now this chain for resonance mass
+ IFP(1) = IDT_IPDG2B(IFPR2,1,2)
+ IFP(2) = 0
+ IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
+ IFT(1) = IDT_IPDG2B(IFTA2,1,2)
+ IFT(2) = 0
+ IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
+ IDCH2 = 2
+ IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
+ IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
+ CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
+ & AMCH2,AMCH2N,IDCH2,IREJ1)
+ IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,*) ' correction for resonance not poss.'
+**sr test
+C GOTO 1
+C GOTO 9999
+**
+ ENDIF
+* store final configuration for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ DO 5 J=1,4
+ PHKK(J,IMO11) = PP1(J)
+ PHKK(J,IMO21) = PP2(J)
+ PHKK(J,IMO12) = PT1(J)
+ PHKK(J,IMO22) = PT2(J)
+ 5 CONTINUE
+* correct entries of chains
+ DO 3 K=1,4
+ PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
+ PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
+ 3 CONTINUE
+ AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
+ AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
+ & PHKK(3,IMMX)**2
+* ?? the following should now be obsolete
+**sr test
+C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
+ IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
+**
+ WRITE(LOUT,'(1X,A,4G10.3)')
+ & 'EVTRES: inonsistent mass-corr.',AM1,AM2
+C GOTO 9999
+ GOTO 1
+ ENDIF
+ PHKK(5,I) = SQRT(AM1)
+ PHKK(5,IMMX) = SQRT(AM2)
+ IDRES(I) = IDRES(I)/100
+ IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
+ & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
+ WRITE(LOUT,'(1X,A,4G10.3)')
+ & 'EVTRES: inconsistent chain-masses',
+ & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
+ GOTO 9999
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+ 6 CONTINUE
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_GETSPT.FOR
+*COPY DT_GETSPT
+*
+*===getspt=============================================================*
+*
+ SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
+ & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
+ & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
+
+************************************************************************
+* This version dated 12.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+ DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
+ & PT2(4),PT2I(4),P1(4),P2(4),
+ & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
+ & PTOTI(4),PTOTF(4),DIFF(4)
+
+ IC = 0
+ IREJ = 0
+C B33P = 4.0D0
+C B33T = 4.0D0
+C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
+C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
+ REDU = 1.0D0
+C B33P = 3.5D0
+C B33T = 3.5D0
+ B33P = 4.0D0
+ B33T = 4.0D0
+ IF (IDIFF.NE.0) THEN
+ B33P = 16.0D0
+ B33T = 16.0D0
+ ENDIF
+
+ DO 1 I=1,4
+ PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
+ PP1(I) = PP1I(I)
+ PP2(I) = PP2I(I)
+ PT1(I) = PT1I(I)
+ PT2(I) = PT2I(I)
+ 1 CONTINUE
+* get initial chain masses
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1 = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2 = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
+ & AM1,AM2
+ GOTO 9999
+ ENDIF
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ AM1N = ZERO
+ AM2N = ZERO
+
+ MODE = 0
+C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
+C MODE = 0
+C ELSE
+C MODE = 1
+C IF (AM1.LT.0.6) THEN
+C B33P = 10.0D0
+C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
+CC B33P = 4.0D0
+C ENDIF
+C IF (AM2.LT.0.6) THEN
+C B33T = 10.0D0
+C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
+CC B33T = 4.0D0
+C ENDIF
+C ENDIF
+
+* check chain masses for very low mass chains
+C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
+C & AM1,DUM,-IDCH1,IREJ1)
+C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
+C & AM2,DUM,-IDCH2,IREJ2)
+C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
+C B33P = 20.0D0
+C B33T = 20.0D0
+C ENDIF
+
+ JMSHL = IMSHL
+
+ 2 CONTINUE
+ IC = IC+1
+ IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
+ IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
+ IF (MOD(IC,18).EQ.0) REDU = 0.0D0
+C IF (MOD(IC,19).EQ.0) JMSHL = 0
+ IF (MOD(IC,20).EQ.0) GOTO 7
+C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
+C RETURN
+C GOTO 9999
+C ENDIF
+
+* get transverse momentum
+ IF (LINTPT) THEN
+ ES = -2.0D0/(B33P**2)
+ & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
+ HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
+ HPSP = HPSP*REDU
+ ES = -2.0D0/(B33T**2)
+ & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
+ HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
+ HPST = HPST*REDU
+ ELSE
+ HPSP = ZERO
+ HPST = ZERO
+ ENDIF
+ CALL DT_DSFECF(SFE1,CFE1)
+ CALL DT_DSFECF(SFE2,CFE2)
+ IF (MODE.EQ.0) THEN
+ PP1(1) = PP1I(1)+HPSP*CFE1
+ PP1(2) = PP1I(2)+HPSP*SFE1
+ PP2(1) = PP2I(1)-HPSP*CFE1
+ PP2(2) = PP2I(2)-HPSP*SFE1
+ PT1(1) = PT1I(1)+HPST*CFE2
+ PT1(2) = PT1I(2)+HPST*SFE2
+ PT2(1) = PT2I(1)-HPST*CFE2
+ PT2(2) = PT2I(2)-HPST*SFE2
+ ELSE
+ PP1(1) = PP1I(1)+HPSP*CFE1
+ PP1(2) = PP1I(2)+HPSP*SFE1
+ PT1(1) = PT1I(1)-HPSP*CFE1
+ PT1(2) = PT1I(2)-HPSP*SFE1
+ PP2(1) = PP2I(1)+HPST*CFE2
+ PP2(2) = PP2I(2)+HPST*SFE2
+ PT2(1) = PT2I(1)-HPST*CFE2
+ PT2(2) = PT2I(2)-HPST*SFE2
+ ENDIF
+
+* put partons on mass shell
+ XMP1 = 0.0D0
+ XMT1 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XMP1 = PYMASS(IFPR1)
+ XMT1 = PYMASS(IFTA1)
+
+ ENDIF
+ CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ DO 3 I=1,4
+ PTOTF(I) = P1(I)+P2(I)
+ PP1(I) = P1(I)
+ PT1(I) = P2(I)
+ 3 CONTINUE
+ XMP2 = 0.0D0
+ XMT2 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XMP2 = PYMASS(IFPR2)
+ XMT2 = PYMASS(IFTA2)
+
+ ENDIF
+ CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ DO 4 I=1,4
+ PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
+ PP2(I) = P1(I)
+ PT2(I) = P2(I)
+ 4 CONTINUE
+
+* check consistency
+ DO 5 I=1,4
+ DIFF(I) = PTOTI(I)-PTOTF(I)
+ 5 CONTINUE
+ IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
+ & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
+ WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
+ GOTO 9999
+ ENDIF
+ PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
+ AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
+ PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
+ AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
+ PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
+ AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
+ PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
+ AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
+ IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
+ & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
+ & THEN
+ WRITE(LOUT,'(1X,A,2(4G10.3,/))')
+ & 'GETSPT: inconsistent masses',
+ & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
+* sr 22.11.00: commented. It should only have inconsistent masses for
+* ultrahigh energies due to rounding problems
+C GOTO 9999
+ ENDIF
+
+* get chain masses
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1N = (ECH+PTOCH)*(ECH-PTOCH)
+ PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+ & +(PP2(3)+PT2(3))**2)
+ ECH = PP2(4)+PT2(4)
+ AM2N = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
+ & AM1N,AM2N
+ GOTO 2
+ ENDIF
+ AM1N = SQRT(AM1N)
+ AM2N = SQRT(AM2N)
+
+* check chain masses for very low mass chains
+ CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
+ & AM1N,DUM,-IDCH1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
+ & AM2N,DUM,-IDCH2,IREJ2)
+ IF (IREJ2.NE.0) GOTO 2
+
+ 7 CONTINUE
+ IF (AM1N.GT.ZERO) THEN
+ AM1 = AM1N
+ AM2 = AM2N
+ ENDIF
+ DO 6 I=1,4
+ PP1I(I) = PP1(I)
+ PP2I(I) = PP2(I)
+ PT1I(I) = PT1(I)
+ PT2I(I) = PT2(I)
+ 6 CONTINUE
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_SAPTRE.FOR
+*COPY DT_SAPTRE
+*
+*===saptre=============================================================*
+*
+ SUBROUTINE DT_SAPTRE(IDX1,IDX2)
+
+************************************************************************
+* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
+* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
+* Adopted from the original SAPTRE written by J. Ranft. *
+* This version dated 18.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ DIMENSION PA1(4),PA2(4),P1(4),P2(4)
+
+ DATA B3 /4.0D0/
+
+ ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
+ ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
+ ESMAX = MIN(ESMAX1,ESMAX2)
+ IF (ESMAX.LE.0.05D0) RETURN
+
+ HMA = PHKK(5,IDX1)
+ DO 1 K=1,4
+ PA1(K) = PHKK(K,IDX1)
+ PA2(K) = PHKK(K,IDX2)
+ 1 CONTINUE
+
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
+ ENDIF
+
+ EXEB = 0.0D0
+ IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
+ BEXP = HMA*(1.0D0-EXEB)/B3
+ AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
+ WA = AXEXP/(BEXP+AXEXP)
+ XAB = DT_RNDM(WA)
+ 10 CONTINUE
+* ES is the transverse kinetic energy
+ IF (XAB.LT.WA)THEN
+ X = DT_RNDM(WA)
+ Y = DT_RNDM(WA)
+ ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
+ ELSE
+ X = DT_RNDM(Y)
+ ES = ABS(-LOG(X+TINY7)/B3)
+ ENDIF
+ IF (ES.GT.ESMAX) GOTO 10
+ ES = ES+HMA
+* transverse momentum
+ HPS = SQRT((ES-HMA)*(ES+HMA))
+
+ CALL DT_DSFECF(SFE,CFE)
+ HPX = HPS*CFE
+ HPY = HPS*SFE
+ PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
+ PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
+ IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
+
+C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
+C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
+ PA1(1) = PA1(1)+HPX
+ PA1(2) = PA1(2)+HPY
+ PA2(1) = PA2(1)-HPX
+ PA2(2) = PA2(2)-HPY
+
+* put resonances on mass-shell again
+ XM1 = PHKK(5,IDX1)
+ XM2 = PHKK(5,IDX2)
+ CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) RETURN
+
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
+ IF (IREJ1.NE.0) RETURN
+ ENDIF
+
+ DO 2 K=1,4
+ PHKK(K,IDX1) = P1(K)
+ PHKK(K,IDX2) = P2(K)
+ 2 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_CRONIN.FOR
+*COPY DT_CRONIN
+*
+*===cronin=============================================================*
+*
+ SUBROUTINE DT_CRONIN(INCL)
+
+************************************************************************
+* Cronin-Effect. Multiple scattering of partons at chain ends. *
+* INCL = 1 multiple sc. in projectile *
+* = 2 multiple sc. in target *
+* This version dated 05.01.96 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+ DIMENSION R(3),PIN(4),POUT(4),DEV(4)
+
+ DO 1 K=1,4
+ DEV(K) = ZERO
+ 1 CONTINUE
+
+ DO 2 I=NPOINT(2),NHKK
+ IF (ISTHKK(I).LT.0) THEN
+* get z-position of the chain
+ R(1) = VHKK(1,I)*1.0D12
+ IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
+ R(2) = VHKK(2,I)*1.0D12
+ IDXNU = JMOHKK(1,I)
+ IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
+ & IDXNU = JMOHKK(1,I-1)
+ IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
+ & IDXNU = JMOHKK(1,I+1)
+ R(3) = VHKK(3,IDXNU)*1.0D12
+* position of target parton the chain is connected to
+ DO 3 K=1,4
+ PIN(K) = PHKK(K,I)
+ 3 CONTINUE
+* multiple scattering of parton with DTEVT1-index I
+ CALL DT_CROMSC(PIN,R,POUT,INCL)
+**testprint
+C IF (NEVHKK.EQ.5) THEN
+C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
+C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
+C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
+C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
+C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
+C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
+C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
+C ENDIF
+**
+* increase accumulator by energy-momentum difference
+ DO 4 K=1,4
+ DEV(K) = DEV(K)+POUT(K)-PIN(K)
+ PHKK(K,I) = POUT(K)
+ 4 CONTINUE
+ PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+ & PHKK(2,I)**2-PHKK(3,I)**2))
+ ENDIF
+ 2 CONTINUE
+
+* dump accumulator to momenta of valence partons
+ NVAL = 0
+ ETOT = 0.0D0
+ DO 5 I=NPOINT(2),NHKK
+ IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
+ NVAL = NVAL+1
+ ETOT = ETOT+PHKK(4,I)
+ ENDIF
+ 5 CONTINUE
+C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
+ 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
+ & 9X,4E12.4)
+ DO 6 I=NPOINT(2),NHKK
+ IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
+ E = PHKK(4,I)
+ DO 7 K=1,4
+C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
+ PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
+ 7 CONTINUE
+ PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+ & PHKK(2,I)**2-PHKK(3,I)**2))
+ ENDIF
+ 6 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_CROMSC.FOR
+*COPY DT_CROMSC
+*
+*===cromsc=============================================================*
+*
+ SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
+
+************************************************************************
+* Cronin-Effect. Multiple scattering of one parton passing through *
+* nuclear matter. *
+* PIN(4) input 4-momentum of parton *
+* POUT(4) 4-momentum of parton after mult. scatt. *
+* R(3) spatial position of parton in target nucleus *
+* INCL = 1 multiple sc. in projectile *
+* = 2 multiple sc. in target *
+* This is a revised version of the original version written by J. Ranft*
+* This version dated 17.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
+
+ LOGICAL LSTART
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ DIMENSION PIN(4),POUT(4),R(3)
+
+ DATA LSTART /.TRUE./
+
+ IRCRON(1) = IRCRON(1)+1
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) CRONCO
+ 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
+ & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
+ LSTART = .FALSE.
+ ENDIF
+
+ NCBACK = 0
+ RNCL = RPROJ
+ IF (INCL.EQ.2) RNCL = RTARG
+
+* Lorentz-transformation into Lab.
+ MODE = -(INCL+1)
+ CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
+
+ PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
+ IF (PTOT.LE.8.0D0) GOTO 9997
+
+* direction cosines of parton before mult. scattering
+ COSX = PIN(1)/PTOT
+ COSY = PIN(2)/PTOT
+ COSZ = PZ/PTOT
+
+ RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
+ IF (RTESQ.GE.-TINY3) GOTO 9999
+
+* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
+* in the direction of particle motion
+
+ A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
+ TMP = A**2-RTESQ
+ IF (TMP.LT.ZERO) GOTO 9998
+ DIST = -A+SQRT(TMP)
+
+* multiple scattering angle
+ THETO = CRONCO*SQRT(DIST)/PTOT
+ IF (THETO.GT.0.1D0) THETO=0.1D0
+
+ 1 CONTINUE
+* Gaussian sampling of spatial angle
+ CALL DT_RANNOR(R1,R2)
+ THETA = ABS(R1*THETO)
+ IF (THETA.GT.0.3D0) GOTO 9997
+ CALL DT_DSFECF(SFE,CFE)
+ COSTH = COS(THETA)
+ SINTH = SIN(THETA)
+
+* new direction cosines
+ CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
+ & COSXN,COSYN,COSZN)
+
+ POUT(1) = COSXN*PTOT
+ POUT(2) = COSYN*PTOT
+ PZ = COSZN*PTOT
+* Lorentz-transformation into nucl.-nucl. cms
+ MODE = INCL+1
+ CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
+
+C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
+C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
+ IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
+ THETO = THETO/2.0D0
+ NCBACK = NCBACK+1
+ IF (MOD(NCBACK,200).EQ.0) THEN
+ WRITE(LOUT,1001) THETO,PIN,POUT
+ 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
+ & E12.4,/,1X,' PIN :',4E12.4,/,
+ & 1X,' POUT:',4E12.4)
+ GOTO 9997
+ ENDIF
+ GOTO 1
+ ENDIF
+
+ RETURN
+
+ 9997 IRCRON(2) = IRCRON(2)+1
+ GOTO 9999
+ 9998 IRCRON(3) = IRCRON(3)+1
+
+ 9999 CONTINUE
+ DO 100 K=1,4
+ POUT(K) = PIN(K)
+ 100 CONTINUE
+ RETURN
+ END
+
+*$ CREATE DT_COM2CR.FOR
+*COPY DT_COM2CR
+*
+*===com2sr=============================================================*
+*
+ SUBROUTINE DT_COM2CR
+
+************************************************************************
+* COMbine q-aq chains to Color Ropes (qq-aqaq). *
+* CUTOF parameter determining minimum number of not *
+* combined q-aq chains *
+* This subroutine replaces KKEVCC etc. *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ DIMENSION IDXQA(248),IDXAQ(248)
+
+ ICCHAI(1,9) = ICCHAI(1,9)+1
+ NQA = 0
+ NAQ = 0
+* scan DTEVT1 for q-aq, aq-q chains
+ DO 10 I=NPOINT(3),NHKK
+* skip "chains" which are resonances
+ IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
+ MO1 = JMOHKK(1,I)
+ MO2 = JMOHKK(2,I)
+ IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
+* q-aq, aq-q chain found, keep index
+ IF (IDHKK(MO1).GT.0) THEN
+ NQA = NQA+1
+ IDXQA(NQA) = I
+ ELSE
+ NAQ = NAQ+1
+ IDXAQ(NAQ) = I
+ ENDIF
+ ENDIF
+ ENDIF
+ 10 CONTINUE
+
+* minimum number of q-aq chains requested for the same projectile/
+* target
+ NCHMIN = IDT_NPOISS(CUTOF)
+
+* combine q-aq chains of the same projectile
+ CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
+* combine q-aq chains of the same target
+ CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
+* combine aq-q chains of the same projectile
+ CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
+* combine aq-q chains of the same target
+ CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
+
+ RETURN
+ END
+
+*$ CREATE DT_SCN4CR.FOR
+*COPY DT_SCN4CR
+*
+*===scn4cr=============================================================*
+*
+ SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
+
+************************************************************************
+* SCan q-aq chains for Color Ropes. *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ DIMENSION IDXCH(248),IDXJN(248)
+
+ DO 1 I=1,NCH
+ IF (IDXCH(I).GT.0) THEN
+ NJOIN = 1
+ IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
+ IDXJN(NJOIN) = I
+ IF (I.LT.NCH) THEN
+ DO 2 J=I+1,NCH
+ IF (IDXCH(J).GT.0) THEN
+ IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
+ IF (IDXMO.EQ.IDXMO1) THEN
+ NJOIN = NJOIN+1
+ IDXJN(NJOIN) = J
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ IF (NJOIN.GE.NCHMIN+2) THEN
+ NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
+ DO 3 J=1,2*NJ,2
+ CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
+ IF (IREJ1.NE.0) GOTO 3
+ IDXCH(IDXJN(J)) = 0
+ IDXCH(IDXJN(J+1)) = 0
+ 3 CONTINUE
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_JOIN.FOR
+*COPY DT_JOIN
+*
+*===join===============================================================*
+*
+ SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
+
+************************************************************************
+* This subroutine joins two q-aq chains to one qq-aqaq chain. *
+* IDX1, IDX2 DTEVT1 indices of chains to be joined *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+ DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
+
+ IREJ = 0
+
+ IDX(1) = IDX1
+ IDX(2) = IDX2
+ DO 1 I=1,2
+ DO 2 J=1,2
+ MO(I,J) = JMOHKK(J,IDX(I))
+ ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
+ 2 CONTINUE
+ 1 CONTINUE
+
+* check consistency
+ IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
+ & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
+ & ((ID(1,1)*ID(2,1)).LT.0).OR.
+ & ((ID(1,2)*ID(2,2)).LT.0)) THEN
+ WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
+ & MO(2,2)
+ 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
+ & 2I5,' chain ',I4,':',2I5)
+ ENDIF
+
+* join chains
+ DO 3 K=1,4
+ PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
+ PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
+ 3 CONTINUE
+ IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
+ IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
+ IST1 = ISTHKK(MO(1,1))
+ IST2 = ISTHKK(MO(1,2))
+
+* put partons again on mass shell
+ XM1 = 0.0D0
+ XM2 = 0.0D0
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IF1)
+ XM2 = PYMASS(IF2)
+
+ ENDIF
+ CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 I=1,4
+ PP(I) = P1(I)
+ PT(I) = P2(I)
+ 4 CONTINUE
+
+* store new partons in DTEVT1
+ CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
+ & 0,0,0)
+ CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
+ & 0,0,0)
+ DO 5 K=1,4
+ PCH(K) = PP(K)+PT(K)
+ 5 CONTINUE
+
+* check new chain for lower mass limit
+ IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+ AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
+ CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
+ & AMCH,AMCHN,3,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ NHKK = NHKK-2
+ GOTO 9999
+ ENDIF
+ ENDIF
+
+ ICCHAI(2,9) = ICCHAI(2,9)+1
+* store new chain in DTEVT1
+ KCH = 191
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
+ IDHKK(IDX(1)) = 22222
+ IDHKK(IDX(2)) = 22222
+* special treatment for space-time coordinates
+ DO 6 K=1,4
+ VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
+ WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
+ 6 CONTINUE
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*$ CREATE DT_XSGLAU.FOR
+*COPY DT_XSGLAU
+*
+*===xsglau=============================================================*
+*
+ SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
+
+************************************************************************
+* Total, elastic, quasi-elastic, inelastic cross sections according to *
+* Glauber's approach. *
+* NA / NB mass numbers of proj./target nuclei *
+* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
+* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
+* IE,IQ indices of energy and virtuality (the latter for gamma *
+* projectiles only) *
+* NIDX index of projectile/target nucleus *
+* This version dated 17.3.98 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ COMPLEX*16 CZERO,CONE,CTWO
+ CHARACTER*12 CFILE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
+ & ONETHI=ONE/THREE,TINY25=1.0D-25)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & GEV2FM = 0.1972D0,
+ & ALPHEM = ONE/137.0D0,
+* proton mass
+ & AMP = 0.938D0,
+ & AMP2 = AMP**2,
+* approx. nucleon radius
+ & RNUCLE = 1.12D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* parameters for hA-diffraction
+ COMMON /DTDIHA/ DIBETA,DIALPH
+
+ COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
+ & OMPP11,OMPP12,OMPP21,OMPP22,
+ & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
+ & PPTMP1,PPTMP2
+ COMPLEX*16 C,CA,CI
+ DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
+ & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
+ & BPROD(KSITEB)
+
+ PARAMETER (NPOINT=16)
+ DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+
+ LOGICAL LFIRST,LOPEN
+ DATA LFIRST,LOPEN /.TRUE.,.FALSE./
+
+ NTARG = ABS(NIDX)
+* for quasi-elastic neutrino scattering set projectile to proton
+* it should not have an effect since the whole Glauber-formalism is
+* not needed for these interactions..
+ IF (MCGENE.EQ.4) THEN
+ IJPROJ = 1
+ ELSE
+ IJPROJ = JJPROJ
+ ENDIF
+
+ IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
+ I = INDEX(CGLB,' ')
+ IF (I.EQ.0) THEN
+ CFILE = CGLB//'.glb'
+ OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
+ ELSEIF (I.GT.1) THEN
+ CFILE = CGLB(1:I-1)//'.glb'
+ OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
+ ELSE
+ STOP 'XSGLAU 1'
+ ENDIF
+ LOPEN = .TRUE.
+ ENDIF
+
+ CZERO = DCMPLX(ZERO,ZERO)
+ CONE = DCMPLX(ONE,ZERO)
+ CTWO = DCMPLX(TWO,ZERO)
+ NEBINI = IE
+ NQBINI = IQ
+
+* re-define kinematics
+ S = ECMI**2
+ Q2 = Q2I
+ X = XI
+* g(Q2=0)-A, h-A, A-A scattering
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(S+Q2-AMP2)
+* g(Q2>0)-A scattering
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
+ X = Q2/(S+Q2-AMP2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
+ Q2 = (S-AMP2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ S = Q2*(ONE-X)/X+AMP2
+ ELSE
+ WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
+ STOP
+ ENDIF
+ ECMNN(IE) = SQRT(S)
+ Q2G(IQ) = Q2
+ XNU = (S+Q2-AMP2)/(TWO*AMP)
+
+* parameters determining statistics in evaluating Glauber-xsection
+ NSTATB = JSTATB
+ NSITEB = JBINSB
+ IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
+
+* set up interaction geometry (common /DTGLAM/)
+* projectile/target radii
+ RPRNCL = DT_RNCLUS(NA)
+ RTANCL = DT_RNCLUS(NB)
+ IF (IJPROJ.EQ.7) THEN
+ RASH(1) = ZERO
+ RBSH(NTARG) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
+ ELSE
+ IF (NIDX.LE.-1) THEN
+ RASH(1) = RPRNCL
+ RBSH(NTARG) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
+ ELSE
+ RASH(NTARG) = RPRNCL
+ RBSH(1) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
+ ENDIF
+ ENDIF
+* maximum impact-parameter
+ BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
+
+* slope, rho ( Re(f(0))/Im(f(0)) )
+ IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
+ & BSLOPE,0)
+ ELSE
+ BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
+ ENDIF
+ IF (ECMNN(IE).LE.3.0D0) THEN
+ ROSH = -0.43D0
+ ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
+ ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
+ ELSEIF (ECMNN(IE).GT.50.0D0) THEN
+ ROSH = 0.1D0
+ ENDIF
+ ELSEIF (IJPROJ.EQ.7) THEN
+ ROSH = 0.1D0
+ ELSE
+ BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
+ ROSH = 0.01D0
+ ENDIF
+
+* projectile-nucleon xsection (in fm)
+ IF (IJPROJ.EQ.7) THEN
+ SIGSH = DT_SIGVP(X,Q2)/10.0D0
+ ELSE
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+
+* parameters for projectile diffraction (hA scattering only)
+ IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
+ & .AND.(DIBETA.GE.ZERO)) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
+C DIBETA = SDIF1/STOT
+ DIBETA = 0.2D0
+ DIGAMM = SQRT(DIALPH**2+DIBETA**2)
+ IF (DIBETA.LE.ZERO) THEN
+ ALPGAM = ONE
+ ELSE
+ ALPGAM = DIALPH/DIGAMM
+ ENDIF
+ FACDI1 = ONE-ALPGAM
+ FACDI2 = ONE+ALPGAM
+ FACDI = SQRT(FACDI1*FACDI2)
+ WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
+ ELSE
+ DIBETA = -1.0D0
+ DIALPH = ZERO
+ DIGAMM = ZERO
+ FACDI1 = ZERO
+ FACDI2 = 2.0D0
+ FACDI = ZERO
+ ENDIF
+
+* initializations
+ DO 10 I=1,NSITEB
+ BSITE( 0,IQ,NTARG,I) = ZERO
+ BSITE(IE,IQ,NTARG,I) = ZERO
+ BPROD(I) = ZERO
+ 10 CONTINUE
+ STOT = ZERO
+ STOT2 = ZERO
+ SELA = ZERO
+ SELA2 = ZERO
+ SQEP = ZERO
+ SQEP2 = ZERO
+ SQET = ZERO
+ SQET2 = ZERO
+ SQE2 = ZERO
+ SQE22 = ZERO
+ SPRO = ZERO
+ SPRO2 = ZERO
+ SDEL = ZERO
+ SDEL2 = ZERO
+ SDQE = ZERO
+ SDQE2 = ZERO
+ FACN = ONE/DBLE(NSTATB)
+
+ IPNT = 0
+ RPNT = ZERO
+
+* initialize Gauss-integration for photon-proj.
+ JPOINT = 1
+ IF (IJPROJ.EQ.7) THEN
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECMNN(IE)-AMP)**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+ XAMLO = LOG( AMLO2+Q2 )
+ XAMHI = LOG( AMHI2+Q2 )
+**PHOJET105a
+C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+ CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+
+**
+ JPOINT = NPOINT
+* ratio direct/total photon-nucleon xsection
+ CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
+ ENDIF
+
+* read pre-initialized profile-function from file
+ IF (IOGLB.EQ.1) THEN
+ READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
+ IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
+ WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
+ & NA,NB,NSTATB,NSITEB
+ 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
+ & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
+ & ' (NA,NB,NSTATB,NSITEB) ',4I10)
+ STOP
+ ENDIF
+ IF (LFIRST) WRITE(LOUT,1001) CFILE
+ 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
+ & 'file ',A12,/)
+ READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
+ & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
+ & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
+ READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
+ & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
+ & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
+ NLINES = INT(DBLE(NSITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 21 I=1,NLINES
+ ISTART = 7*I-6
+ READ(LDAT,'(7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
+ 21 CONTINUE
+ ENDIF
+ ISTART = 7*NLINES+1
+ IF (ISTART.LE.NSITEB) THEN
+ READ(LDAT,'(7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
+ ENDIF
+ LFIRST = .FALSE.
+ GOTO 100
+* variable projectile/target/energy runs:
+* read pre-initialized profile-functions from file
+ ELSEIF (IOGLB.EQ.100) THEN
+ CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
+ GOTO 100
+ ENDIF
+
+* cross sections averaged over NSTATB nucleon configurations
+ DO 11 IS=1,NSTATB
+C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
+ STOTN = ZERO
+ SELAN = ZERO
+ SQEPN = ZERO
+ SQETN = ZERO
+ SQE2N = ZERO
+ SPRON = ZERO
+ SDELN = ZERO
+ SDQEN = ZERO
+
+ IF (NIDX.LE.-1) THEN
+ CALL DT_CONUCL(COOP1,NA,RASH(1),0)
+ CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ CALL DT_CONUCL(COOP2,NA,RASH(1),0)
+ CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
+ ENDIF
+ ELSE
+ CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
+ ENDIF
+ ENDIF
+
+* integration over impact parameter B
+ DO 12 IB=1,NSITEB-1
+ STOTB = ZERO
+ SELAB = ZERO
+ SQEPB = ZERO
+ SQETB = ZERO
+ SQE2B = ZERO
+ SPROB = ZERO
+ SDIR = ZERO
+ SDELB = ZERO
+ SDQEB = ZERO
+ B = DBLE(IB)*BSTEP(NTARG)
+ FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
+
+* integration over M_V^2 for photon-proj.
+ DO 14 IM=1,JPOINT
+ PP11(1) = CONE
+ PP12(1) = CONE
+ PP21(1) = CONE
+ PP22(1) = CONE
+ IF (IJPROJ.EQ.7) THEN
+ DO 13 K=2,NB
+ PP11(K) = CONE
+ PP12(K) = CONE
+ PP21(K) = CONE
+ PP22(K) = CONE
+ 13 CONTINUE
+ ENDIF
+ SHI = ZERO
+ FACM = ONE
+ DCOH = 1.0D10
+
+ IF (IJPROJ.EQ.7) THEN
+ AMV2 = EXP(ABSZX(IM))-Q2
+ AMV = SQRT(AMV2)
+ IF (AMV2.LT.16.0D0) THEN
+ R = TWO
+ ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
+ R = 10.0D0/3.0D0
+ ELSE
+ R = 11.0D0/3.0D0
+ ENDIF
+* define M_V dependent properties of nucleon scattering amplitude
+* V_M-nucleon xsection
+ SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
+ SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
+* slope-parametrisation a la Kaidalov
+ BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
+ & +0.25D0*LOG(S/(AMV2+Q2)))
+* coherence length
+ IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
+* integration weight factor
+ FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
+ & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
+ ENDIF
+ GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
+ GAM = GSH
+ IF (IJPROJ.EQ.7) THEN
+ RCA = GAM*SIGMV/TWOPI
+ ELSE
+ RCA = GAM*SIGSH/TWOPI
+ ENDIF
+ FCA = -ROSH*RCA
+ CA = DCMPLX(RCA,FCA)
+ CI = CONE
+
+ DO 15 INA=1,NA
+ KK1 = 1
+ INT1 = 1
+ KK2 = 1
+ INT2 = 1
+ DO 16 INB=1,NB
+* photon-projectile: check for supression by coherence length
+ IF (IJPROJ.EQ.7) THEN
+ IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
+ KK1 = INB
+ INT1 = INT1+1
+ ENDIF
+ IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
+ KK2 = INB
+ INT2 = INT2+1
+ ENDIF
+ ENDIF
+
+ X11 = B+COOT1(1,INB)-COOP1(1,INA)
+ Y11 = COOT1(2,INB)-COOP1(2,INA)
+ XY11 = GAM*(X11*X11+Y11*Y11)
+ IF (XY11.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY11)
+ AR = DBLE(PP11(INT1))
+ AI = DIMAG(PP11(INT1))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP11(INT1) = DCMPLX(AR,AI)
+ PP11(INT1) = PP11(INT1)*C
+ AR = DBLE(C)
+ AI = DIMAG(C)
+ SHI = SHI+LOG(AR*AR+AI*AI)
+ ENDIF
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ X12 = B+COOT2(1,INB)-COOP1(1,INA)
+ Y12 = COOT2(2,INB)-COOP1(2,INA)
+ XY12 = GAM*(X12*X12+Y12*Y12)
+ IF (XY12.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY12)
+ AR = DBLE(PP12(INT2))
+ AI = DIMAG(PP12(INT2))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP12(INT2) = DCMPLX(AR,AI)
+ PP12(INT2) = PP12(INT2)*C
+ ENDIF
+ X21 = B+COOT1(1,INB)-COOP2(1,INA)
+ Y21 = COOT1(2,INB)-COOP2(2,INA)
+ XY21 = GAM*(X21*X21+Y21*Y21)
+ IF (XY21.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY21)
+ AR = DBLE(PP21(INT1))
+ AI = DIMAG(PP21(INT1))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP21(INT1) = DCMPLX(AR,AI)
+ PP21(INT1) = PP21(INT1)*C
+ ENDIF
+ X22 = B+COOT2(1,INB)-COOP2(1,INA)
+ Y22 = COOT2(2,INB)-COOP2(2,INA)
+ XY22 = GAM*(X22*X22+Y22*Y22)
+ IF (XY22.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY22)
+ AR = DBLE(PP22(INT2))
+ AI = DIMAG(PP22(INT2))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP22(INT2) = DCMPLX(AR,AI)
+ PP22(INT2) = PP22(INT2)*C
+ ENDIF
+ ENDIF
+ 16 CONTINUE
+ 15 CONTINUE
+
+ OMPP11 = CZERO
+ OMPP21 = CZERO
+ DIPP11 = CZERO
+ DIPP21 = CZERO
+ DO 17 K=1,INT1
+ IF (PP11(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP11 = OMPP11+AVDIPP
+C OMPP11 = OMPP11+(CONE-PP11(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP11 = DIPP11+AVDIPP
+ IF (PP21(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP21 = OMPP21+AVDIPP
+C OMPP21 = OMPP21+(CONE-PP21(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP21 = DIPP21+AVDIPP
+ 17 CONTINUE
+ OMPP12 = CZERO
+ OMPP22 = CZERO
+ DIPP12 = CZERO
+ DIPP22 = CZERO
+ DO 18 K=1,INT2
+ IF (PP12(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP12 = OMPP12+AVDIPP
+C OMPP12 = OMPP12+(CONE-PP12(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP12 = DIPP12+AVDIPP
+ IF (PP22(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP22 = OMPP22+AVDIPP
+C OMPP22 = OMPP22+(CONE-PP22(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP22 = DIPP22+AVDIPP
+ 18 CONTINUE
+
+ SPROM = ONE-EXP(SHI)
+ SPROB = SPROB+FACM*SPROM
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ STOTM = DBLE(OMPP11+OMPP22)
+ SELAM = DBLE(OMPP11*DCONJG(OMPP22))
+ SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
+ SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
+ SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
+ SDELM = DBLE(DIPP11*DCONJG(DIPP22))
+ SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
+ STOTB = STOTB+FACM*STOTM
+ SELAB = SELAB+FACM*SELAM
+ SDELB = SDELB+FACM*SDELM
+ IF (NB.GT.1) THEN
+ SQEPB = SQEPB+FACM*SQEPM
+ SDQEB = SDQEB+FACM*SDQEM
+ ENDIF
+ IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
+ IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
+ IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
+ ENDIF
+
+ 14 CONTINUE
+
+ STOTN = STOTN+FACB*STOTB
+ SELAN = SELAN+FACB*SELAB
+ SQEPN = SQEPN+FACB*SQEPB
+ SQETN = SQETN+FACB*SQETB
+ SQE2N = SQE2N+FACB*SQE2B
+ SPRON = SPRON+FACB*SPROB
+ SDELN = SDELN+FACB*SDELB
+ SDQEN = SDQEN+FACB*SDQEB
+
+ IF (IJPROJ.EQ.7) THEN
+ BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
+ ELSE
+ IF (DIBETA.GT.ZERO) THEN
+ BPROD(IB+1)= BPROD(IB+1)
+ & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
+ ELSE
+ BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
+ ENDIF
+ ENDIF
+
+ 12 CONTINUE
+
+ STOT = STOT +FACN*STOTN
+ STOT2 = STOT2+FACN*STOTN**2
+ SELA = SELA +FACN*SELAN
+ SELA2 = SELA2+FACN*SELAN**2
+ SQEP = SQEP +FACN*SQEPN
+ SQEP2 = SQEP2+FACN*SQEPN**2
+ SQET = SQET +FACN*SQETN
+ SQET2 = SQET2+FACN*SQETN**2
+ SQE2 = SQE2 +FACN*SQE2N
+ SQE22 = SQE22+FACN*SQE2N**2
+ SPRO = SPRO +FACN*SPRON
+ SPRO2 = SPRO2+FACN*SPRON**2
+ SDEL = SDEL +FACN*SDELN
+ SDEL2 = SDEL2+FACN*SDELN**2
+ SDQE = SDQE +FACN*SDQEN
+ SDQE2 = SDQE2+FACN*SDQEN**2
+
+ 11 CONTINUE
+
+* final cross sections
+* 1) total
+ XSTOT(IE,IQ,NTARG) = STOT
+ IF (IJPROJ.EQ.7)
+ & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
+* 2) elastic
+ XSELA(IE,IQ,NTARG) = SELA
+* 3) quasi-el.: A+B-->A+X (excluding 2)
+ XSQEP(IE,IQ,NTARG) = SQEP
+* 4) quasi-el.: A+B-->X+B (excluding 2)
+ XSQET(IE,IQ,NTARG) = SQET
+* 5) quasi-el.: A+B-->X (excluding 2-4)
+ XSQE2(IE,IQ,NTARG) = SQE2
+* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
+ IF (SDEL.GT.ZERO) THEN
+ XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
+ ELSE
+ XSPRO(IE,IQ,NTARG) = SPRO
+ ENDIF
+* 7) projectile diffraction (el. scatt. off target)
+ XSDEL(IE,IQ,NTARG) = SDEL
+* 8) projectile diffraction (quasi-el. scatt. off target)
+ XSDQE(IE,IQ,NTARG) = SDQE
+* stat. errors
+ XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
+ XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
+ XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
+ XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
+ XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
+ XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
+ XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
+ XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
+
+ IF (IJPROJ.EQ.7) THEN
+ BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
+ & -XSQEP(IE,IQ,NTARG)
+ ELSE
+ BNORM = XSPRO(IE,IQ,NTARG)
+ ENDIF
+ DO 19 I=2,NSITEB
+ BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
+ IF ((IE.EQ.1).AND.(IQ.EQ.1))
+ & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
+ 19 CONTINUE
+
+* write profile function data into file
+ IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
+ WRITE(LDAT,'(5I10,1P,E15.5)')
+ & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
+ WRITE(LDAT,'(1P,6E12.5)')
+ & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
+ & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
+ WRITE(LDAT,'(1P,6E12.5)')
+ & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
+ & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
+ NLINES = INT(DBLE(NSITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 20 I=1,NLINES
+ ISTART = 7*I-6
+ WRITE(LDAT,'(1P,7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
+ 20 CONTINUE
+ ENDIF
+ ISTART = 7*NLINES+1
+ IF (ISTART.LE.NSITEB) THEN
+ WRITE(LDAT,'(1P,7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
+ ENDIF
+ ENDIF
+
+ 100 CONTINUE
+
+C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
+
+ RETURN
+ END
+
+*$ CREATE DT_GETBXS.FOR
+*COPY DT_GETBXS
+*
+*===getbxs=============================================================*
+*
+ SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
+
+************************************************************************
+* Biasing in impact parameter space. *
+* XSFRAC = 0 : BLO - minimum impact parameter (input) *
+* BHI - maximum impact parameter (input) *
+* XSFRAC - fraction of cross section corresponding *
+* to impact parameter range (BLO,BHI) *
+* (output) *
+* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
+* BHI - maximum impact parameter giving requested *
+* fraction of cross section in impact *
+* parameter range (0,BMAX) (output) *
+* This version dated 17.03.00 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+ NTARG = ABS(NIDX)
+ IF (XSFRAC.LE.0.0D0) THEN
+ ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
+ IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
+ IF (ILO.GE.IHI) THEN
+ XSFRAC = 0.0D0
+ RETURN
+ ENDIF
+ IF (ILO.EQ.NSITEB-1) THEN
+ FRCLO = BSITE(0,1,NTARG,NSITEB)
+ ELSE
+ FRCLO = BSITE(0,1,NTARG,ILO+1)
+ & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
+ & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
+ ENDIF
+ IF (IHI.EQ.NSITEB-1) THEN
+ FRCHI = BSITE(0,1,NTARG,NSITEB)
+ ELSE
+ FRCHI = BSITE(0,1,NTARG,IHI+1)
+ & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
+ & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
+ ENDIF
+ XSFRAC = FRCHI-FRCLO
+ ELSE
+ BLO = 0.0D0
+ BHI = BMAX(NTARG)
+ DO 1 I=1,NSITEB-1
+ IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
+ FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
+ & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
+ BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_CONUCL.FOR
+*COPY DT_CONUCL
+*
+*===conucl=============================================================*
+*
+ SUBROUTINE DT_CONUCL(X,N,R,MODE)
+
+************************************************************************
+* Calculation of coordinates of nucleons within nuclei. *
+* X(3,N) spatial coordinates of nucleons (in fm) (output) *
+* N / R number of nucleons / radius of nucleus (input) *
+* MODE = 0 coordinates not sorted *
+* = 1 coordinates sorted with increasing X(3,i) *
+* = 2 coordinates sorted with decreasing X(3,i) *
+* This version dated 26.10.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
+ & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
+
+ PARAMETER (TWOPI = 6.283185307179586454D+00 )
+
+ PARAMETER (NSRT=10)
+ DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
+ DIMENSION X(3,N),XTMP(3,260)
+
+ CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
+
+ IF ((MODE.NE.0).AND.(N.GT.4)) THEN
+ K = 0
+ DO 1 I=1,NSRT
+ IF (MODE.EQ.2) THEN
+ ISRT = NSRT+1-I
+ ELSE
+ ISRT = I
+ ENDIF
+ K1 = K
+ DO 2 J=1,ICSRT(ISRT)
+ K = K+1
+ X(1,K) = XTMP(1,IDXSRT(ISRT,J))
+ X(2,K) = XTMP(2,IDXSRT(ISRT,J))
+ X(3,K) = XTMP(3,IDXSRT(ISRT,J))
+ 2 CONTINUE
+ IF (ICSRT(ISRT).GT.1) THEN
+ I0 = K1+1
+ I1 = K
+ CALL DT_SORT(X,N,I0,I1,MODE)
+ ENDIF
+ 1 CONTINUE
+ ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
+ DO 3 I=1,N
+ X(1,I) = XTMP(1,I)
+ X(2,I) = XTMP(2,I)
+ X(3,I) = XTMP(3,I)
+ 3 CONTINUE
+ CALL DT_SORT(X,N,1,N,MODE)
+ ELSE
+ DO 4 I=1,N
+ X(1,I) = XTMP(1,I)
+ X(2,I) = XTMP(2,I)
+ X(3,I) = XTMP(3,I)
+ 4 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_COORDI.FOR
+*COPY DT_COORDI
+*
+*===coordi=============================================================*
+*
+ SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
+
+************************************************************************
+* Calculation of coordinates of nucleons within nuclei. *
+* X(3,N) spatial coordinates of nucleons (in fm) (output) *
+* N / R number of nucleons / radius of nucleus (input) *
+* Based on the original version by Shmakov et al. *
+* This version dated 26.10.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
+ & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
+
+ PARAMETER (TWOPI = 6.283185307179586454D+00 )
+
+ LOGICAL LSTART
+
+ PARAMETER (NSRT=10)
+ DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
+ DIMENSION X(3,260),WD(4),RD(3)
+
+ DATA PDIF/0.545D0/,R2MIN/0.16D0/
+ DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
+ DATA RD /2.09D0, 0.935D0, 0.697D0/
+
+ X1SUM = ZERO
+ X2SUM = ZERO
+ X3SUM = ZERO
+
+ IF (N.EQ.1) THEN
+ X(1,1) = ZERO
+ X(2,1) = ZERO
+ X(3,1) = ZERO
+ ELSEIF (N.EQ.2) THEN
+ EPS = DT_RNDM(RD(1))
+ DO 30 I=1,3
+ IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 50 J=1,3
+ CALL DT_RANNOR(X1,X2)
+ X(J,1) = RD(I)*X1
+ X(J,2) = -X(J,1)
+ 50 CONTINUE
+ ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
+ SIGMA = R/SQRTWO
+ LSTART = .TRUE.
+ CALL DT_RANNOR(X3,X4)
+ DO 100 I=1,N
+ CALL DT_RANNOR(X1,X2)
+ X(1,I) = SIGMA*X1
+ X(2,I) = SIGMA*X2
+ IF (LSTART) GOTO 80
+ X(3,I) = SIGMA*X4
+ CALL DT_RANNOR(X3,X4)
+ GOTO 90
+ 80 CONTINUE
+ X(3,I) = SIGMA*X3
+ 90 CONTINUE
+ LSTART = .NOT.LSTART
+ X1SUM = X1SUM+X(1,I)
+ X2SUM = X2SUM+X(2,I)
+ X3SUM = X3SUM+X(3,I)
+ 100 CONTINUE
+ X1SUM = X1SUM/DBLE(N)
+ X2SUM = X2SUM/DBLE(N)
+ X3SUM = X3SUM/DBLE(N)
+ DO 101 I=1,N
+ X(1,I) = X(1,I)-X1SUM
+ X(2,I) = X(2,I)-X2SUM
+ X(3,I) = X(3,I)-X3SUM
+ 101 CONTINUE
+ ELSE
+
+* maximum nuclear radius for coordinate sampling
+ RMAX = R+4.605D0*PDIF
+
+* initialize pre-sorting
+ DO 121 I=1,NSRT
+ ICSRT(I) = 0
+ 121 CONTINUE
+ DR = TWO*RMAX/DBLE(NSRT)
+
+* sample coordinates for N nucleons
+ DO 140 I=1,N
+ 120 CONTINUE
+ RAD = RMAX*(DT_RNDM(DR))**ONETHI
+ F = DT_DENSIT(N,RAD,R)
+ IF (DT_RNDM(RAD).GT.F) GOTO 120
+* theta, phi uniformly distributed
+ CT = ONE-TWO*DT_RNDM(F)
+ ST = SQRT((ONE-CT)*(ONE+CT))
+ CALL DT_DSFECF(SFE,CFE)
+ X(1,I) = RAD*ST*CFE
+ X(2,I) = RAD*ST*SFE
+ X(3,I) = RAD*CT
+* ensure that distance between two nucleons is greater than R2MIN
+ IF (I.LT.2) GOTO 122
+ I1 = I-1
+ DO 130 I2=1,I1
+ DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
+ & (X(3,I)-X(3,I2))**2
+ IF (DIST2.LE.R2MIN) GOTO 120
+ 130 CONTINUE
+ 122 CONTINUE
+* save index according to z-bin
+ IDXZ = INT( (X(3,I)+RMAX)/DR )+1
+ ICSRT(IDXZ) = ICSRT(IDXZ)+1
+ IDXSRT(IDXZ,ICSRT(IDXZ)) = I
+ X1SUM = X1SUM+X(1,I)
+ X2SUM = X2SUM+X(2,I)
+ X3SUM = X3SUM+X(3,I)
+ 140 CONTINUE
+ X1SUM = X1SUM/DBLE(N)
+ X2SUM = X2SUM/DBLE(N)
+ X3SUM = X3SUM/DBLE(N)
+ DO 141 I=1,N
+ X(1,I) = X(1,I)-X1SUM
+ X(2,I) = X(2,I)-X2SUM
+ X(3,I) = X(3,I)-X3SUM
+ 141 CONTINUE
+
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_DENSIT.FOR
+*COPY DT_DENSIT
+*
+*===densit=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO)
+
+ DIMENSION R0(18),FNORM(18)
+ DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
+ & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
+ & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
+ & 2.72D0, 2.66D0, 2.79D0/
+ DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
+ & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
+ & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
+ & .1214D+01,.1265D+01,.1318D+01/
+ DATA PDIF /0.545D0/
+
+ DT_DENSIT = ZERO
+* shell model
+ IF (NA.LE.4) THEN
+ STOP 'DT_DENSIT-0'
+ ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
+ R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
+ DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
+ & *EXP(-(R/R1)**2)/FNORM(NA)
+* Woods-Saxon
+ ELSEIF (NA.GT.18) THEN
+ DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_RNCLUS.FOR
+*COPY DT_RNCLUS
+*
+*===rnclus=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
+
+************************************************************************
+* Nuclear radius for nucleus with mass number N. *
+* This version dated 26.9.00 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
+
+* nucleon radius
+ PARAMETER (RNUCLE = 1.12D0)
+
+* nuclear radii for selected nuclei
+ DIMENSION RADNUC(18)
+ DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
+ & 2.58D0,2.71D0,2.66D0,2.71D0/
+
+ IF (N.LE.18) THEN
+ IF (RADNUC(N).GT.0.0D0) THEN
+ DT_RNCLUS = RADNUC(N)
+ ELSE
+ DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
+ ENDIF
+ ELSE
+ DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_DENTST.FOR
+*COPY DT_DENTST
+*
+*===dentst=============================================================*
+*
+C PROGRAM DT_DENTST
+ SUBROUTINE DT_DENTST
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
+ OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
+
+ RMIN = 0.0D0
+ RMAX = 8.0D0
+ NBINS = 500.0D0
+ DR = (RMAX-RMIN)/DBLE(NBINS)
+ DO 1 IA=5,18
+ FMAX = 0.0D0
+ DO 2 IR=1,NBINS+1
+ R = RMIN+DBLE(IR-1)*DR
+ F = DT_DENSIT(IA,R,R)
+ IF (F.GT.FMAX) FMAX = F
+ WRITE(40,'(1X,I3,2E15.5)') IA,R,F
+ 2 CONTINUE
+ WRITE(41,'(1X,I3,E15.5)') IA,FMAX
+ 1 CONTINUE
+
+ CLOSE(40)
+ CLOSE(41)
+
+ END
+
+*$ CREATE DT_SHMAKI.FOR
+*COPY DT_SHMAKI
+*
+*===shmaki=============================================================*
+*
+ SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
+
+************************************************************************
+* Initialisation of Glauber formalism. This subroutine has to be *
+* called once (in case of target emulsions as often as many different *
+* target nuclei are considered) before events are sampled. *
+* NA / NCA mass number/charge of projectile nucleus *
+* NB / NCB mass number/charge of target nucleus *
+* IJP identity of projectile (hadrons/leptons/photons) *
+* PPN projectile momentum (for projectile nuclei: *
+* momentum per nucleon) in target rest system *
+* MODE = 0 Glauber formalism invoked *
+* = 1 fitted results are loaded from data-file *
+* = 99 NTARG is forced to be 1 *
+* (used in connection with GLAUBERI-card only) *
+* This version dated 22.03.96 is based on the original SHMAKI-routine *
+* and revised by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
+ & THREE=3.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* kinematical cuts for lepton-nucleus interactions
+ COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+ & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* cuts for variable energy runs
+ COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ DATA NTARG,ICOUT,IVEOUT /0,0,0/
+
+C CALL DT_HISHAD
+C STOP
+
+ NTARG = NTARG+1
+ IF (MODE.EQ.99) NTARG = 1
+ NIDX = -NTARG
+ IF (MODE.EQ.-1) NIDX = NTARG
+
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
+ IF (ICOUT.EQ.1) WRITE(LOUT,1000)
+ 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
+ & ' initialization',/,12X,'--------------------------',
+ & '-------------------------',/)
+
+ IF (MODE.EQ.2) THEN
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
+ CALL DT_SHFAST(MODE,PPN,IBACK)
+ STOP ' Glauber pre-initialization done'
+ ENDIF
+ IF (MODE.EQ.1) THEN
+ CALL DT_PROFBI(NA,NB,PPN,NTARG)
+ ELSE
+ IBACK = 1
+ IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
+ IF (IBACK.EQ.1) THEN
+* lepton-nucleus (variable energy runs)
+ IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
+ & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1002) NB,NCB
+ 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
+ & ' target A/Z: ',I3,' /',I3,/,/,8X,
+ & 'E_cm (GeV) Q^2 (GeV^2)',
+ & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
+ & '--------------------------------',
+ & '------------------------------')
+ AECMLO = LOG10(MIN(UMO,ECMLI))
+ AECMHI = LOG10(MIN(UMO,ECMHI))
+ IESTEP = NEB-1
+ DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
+ IF (AECMLO.EQ.AECMHI) IESTEP = 0
+ DO 1 I=1,IESTEP+1
+ ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
+ IF (Q2HI.GT.0.1D0) THEN
+ IF (Q2LI.LT.0.01D0) THEN
+ CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003)
+ & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ Q2LI = 0.01D0
+ IBIN = 2
+ ELSE
+ IBIN = 1
+ ENDIF
+ IQSTEP = NQB-IBIN
+ AQ2LO = LOG10(Q2LI)
+ AQ2HI = LOG10(Q2HI)
+ DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
+ DO 2 J=IBIN,IQSTEP+IBIN
+ Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
+ CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003) ECMNN(I),
+ & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
+ 2 CONTINUE
+ ELSE
+ CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003)
+ & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ ENDIF
+ 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
+ 1 CONTINUE
+ IVEOUT = 1
+ ELSE
+* hadron/photon/nucleus-nucleus
+ IF ((ABS(VAREHI).GT.ZERO).AND.
+ & (ABS(VAREHI).GT.ABS(VARELO))) THEN
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
+ WRITE(LOUT,1004) NA,NB,NCB
+ 1004 FORMAT(1X,'variable energy run: projectile-id:',
+ & I3,' target A/Z: ',I3,' /',I3,/)
+ WRITE(LOUT,1005)
+ 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
+ & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
+ & ' -------------------------------------',
+ & '--------------------------------------')
+ ENDIF
+ AECMLO = LOG10(VARCLO)
+ AECMHI = LOG10(VARCHI)
+ IESTEP = NEB-1
+ DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
+ IF (AECMLO.EQ.AECMHI) IESTEP = 0
+ DO 3 I=1,IESTEP+1
+ ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
+ AMP = 0.938D0
+ AMT = 0.938D0
+ AMP2 = AMP**2
+ AMT2 = AMT**2
+ ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
+ PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1006)
+ & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
+ 3 CONTINUE
+ IVEOUT = 1
+ ELSE
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
+ & (IOGLB.NE.100)) THEN
+ WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
+ & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
+ 1001 FORMAT(38X,'projectile',
+ & ' target',/,1X,'Mass number / charge',
+ & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
+ & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
+ & 'Parameters of elastic scattering amplitude:',/,5X,
+ & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
+ & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
+ & 'statistics at each b-step',4X,I5,/,/,1X,
+ & 'Prod. cross section ',5X,F10.4,' mb',/)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_PROFBI.FOR
+*COPY DT_PROFBI
+*
+*===profbi=============================================================*
+*
+ SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
+
+************************************************************************
+* Integral over profile function (to be used for impact-parameter *
+* sampling during event generation). *
+* Fitted results are used. *
+* NA / NB mass numbers of proj./target nuclei *
+* PPN projectile momentum (for projectile nuclei: *
+* momentum per nucleon) in target rest system *
+* NTARG index of target material (i.e. kind of nucleus) *
+* This version dated 31.05.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ SAVE
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
+
+ LOGICAL LSTART
+ CHARACTER CNAME*80
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ PARAMETER (NGLMAX=8000)
+ DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
+ & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
+
+ DATA LSTART /.TRUE./
+
+ IF (LSTART) THEN
+* read fit-parameters from file
+ OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
+ I = 0
+ 1 CONTINUE
+ READ(47,'(A80)') CNAME
+ IF (CNAME.EQ.'STOP') GOTO 2
+ I = I+1
+ READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
+ & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
+ & GLAFIT(4,I),GLAFIT(5,I)
+ IF (I+1.GT.NGLMAX) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
+ & 'program stopped')
+ STOP
+ ENDIF
+ GOTO 1
+ 2 CONTINUE
+ NGLPAR = I
+ LSTART = .FALSE.
+ ENDIF
+
+ NNA = NA
+ NNB = NB
+ IF (NA.GT.NB) THEN
+ NNA = NB
+ NNB = NA
+ ENDIF
+ IDXGLA = 0
+ DO 3 J=1,NGLPAR
+ IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
+ IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
+ DO 4 K=1,J-1
+ IPOINT = J-K
+ IF (J.EQ.NGLPAR) IPOINT = J+1-K
+ IF ((NNA.GT.NGLIP(IPOINT)).OR.
+ & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
+ IF (IPOINT.EQ.1) IPOINT = 0
+ NATMP = NGLIP(IPOINT+1)
+ IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
+ IDXGLA = IPOINT+1
+ GOTO 6
+ ELSE
+ J1BEG = IPOINT+1
+ J1END = J
+C IF (J.EQ.NGLPAR) THEN
+C J1BEG = IPOINT
+C J1END = J
+C ENDIF
+ DO 5 J1=J1BEG,J1END
+ IF (NGLIP(J1).EQ.NATMP) THEN
+ IF (PPN.LT.GLAPPN(J1)) THEN
+ IDXGLA = J1
+ GOTO 6
+ ENDIF
+ ELSE
+ IDXGLA = J1-1
+ GOTO 6
+ ENDIF
+ 5 CONTINUE
+ IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
+ & IDXGLA = NGLPAR
+ ENDIF
+ ENDIF
+ 4 CONTINUE
+ ENDIF
+ 3 CONTINUE
+
+ 6 CONTINUE
+ IF (IDXGLA.EQ.0) THEN
+ WRITE(LOUT,1001) NNA,NNB,PPN
+ 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
+ & 2I4,F6.0,') not found ')
+ STOP
+ ENDIF
+
+* no interpolation yet available
+ XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
+
+ BSITE(1,1,NTARG,1) = ZERO
+ DO 10 I=2,NSITEB
+ XX = DBLE(I)
+ POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
+ & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
+ & GLAFIT(5,IDXGLA)*XX**4
+ IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
+ BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
+ IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
+ 10 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_GLAUBE.FOR
+*COPY DT_GLAUBE
+*
+*===glaube=============================================================*
+*
+ SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
+
+************************************************************************
+* Calculation of configuartion of interacting nucleons for one event. *
+* NB / NB mass numbers of proj./target nuclei (input) *
+* B impact parameter (output) *
+* INTT total number of wounded nucleons " *
+* INTA / INTB number of wounded nucleons in proj. / target " *
+* JS / JT(i) number of collisions proj. / target nucleon i is *
+* involved (output) *
+* NIDX index of projectile/target material (input) *
+* = -2 call within FLUKA transport calculation *
+* This is an update of the original routine SHMAKO by J.Ranft/HJM *
+* This version dated 22.03.96 is revised by S. Roesler *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ DIMENSION JS(MAXNCL),JT(MAXNCL)
+
+ NTARG = ABS(NIDX)
+
+* get actual energy from /DTLTRA/
+ ECMNOW = UMO
+ Q2 = VIRT
+*
+* new patch for pre-initialized variable projectile/target/energy runs,
+* bypassed for use within FLUKA (Nidx=-2)
+ IF (IOGLB.EQ.100) THEN
+ IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
+*
+* variable energy run, interpolate profile function
+ ELSE
+ I1 = 1
+ I2 = 1
+ RATE = ONE
+ IF (NEBINI.GT.1) THEN
+ IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
+ DO 1 I=2,NEBINI
+ IF (ECMNOW.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ONE
+ IF (NQBINI.GT.1) THEN
+ IF (Q2.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (Q2.GT.Q2G(1)) THEN
+ DO 3 I=2,NQBINI
+ IF (Q2.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
+ GOTO 4
+ ENDIF
+ 3 CONTINUE
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ DO 5 I=1,KSITEB
+ BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
+ & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
+ & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
+ & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
+ & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
+ 5 CONTINUE
+ ENDIF
+
+ CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
+ IF (NIDX.LE.-1) THEN
+ RPROJ = RASH(1)
+ RTARG = RBSH(NTARG)
+ ELSE
+ RPROJ = RASH(NTARG)
+ RTARG = RBSH(1)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_DIAGR.FOR
+*COPY DT_DIAGR
+*
+*===diagr==============================================================*
+*
+ SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
+ & NIDX)
+
+************************************************************************
+* Based on the original version by Shmakov et al. *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & GEV2FM = 0.1972D0,
+ & ALPHEM = ONE/137.0D0,
+* proton mass
+ & AMP = 0.938D0,
+ & AMP2 = AMP**2,
+* rho0 mass
+ & AMRHO0 = 0.77D0)
+
+ COMPLEX*16 C,CA,CI
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+**PHOJET105a
+C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+**PHOJET112
+
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+**
+
+* coordinates of nucleons
+ COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
+
+* interface between Glauber formalism and DPM
+ COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
+ & INTER1(MAXINT),INTER2(MAXINT)
+
+* statistics: Glauber-formalism
+ COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+
+ DIMENSION JS(MAXNCL),JT(MAXNCL),
+ & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
+ & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
+ DIMENSION NWA(0:210),NWB(0:210)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+ DATA NTARGO,ICNT /0,0/
+
+ NTARG = ABS(NIDX)
+
+ IF (LFIRST) THEN
+ LFIRST = .FALSE.
+ IF (NCOMPO.EQ.0) THEN
+ NCALL = 0
+ NWAMAX = NA
+ NWBMAX = NB
+ DO 17 I=0,210
+ NWA(I) = 0
+ NWB(I) = 0
+ 17 CONTINUE
+ ENDIF
+ ENDIF
+ IF (NTARG.EQ.-1) THEN
+ IF (NCOMPO.EQ.0) THEN
+ WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
+ WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
+ & NCALL,NWAMAX,NWBMAX
+ DO 18 I=1,MAX(NWAMAX,NWBMAX)
+ WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
+ & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
+ & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
+ 18 CONTINUE
+ ENDIF
+ RETURN
+ ENDIF
+
+ DCOH = 1.0D10
+ IPNT = 0
+
+ SQ2 = Q2
+ IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
+ S = ECMNOW**2
+ X = SQ2/(S+SQ2-AMP2)
+ XNU = (S+SQ2-AMP2)/(TWO*AMP)
+* photon projectiles: recalculate photon-nucleon amplitude
+ IF (IJPROJ.EQ.7) THEN
+ 15 CONTINUE
+* VDM assumption: mass of V-meson
+ AMV2 = DT_SAM2(SQ2,ECMNOW)
+ AMV = SQRT(AMV2)
+ IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
+* check for pointlike interaction
+ CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
+**sr 27.10.
+C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
+ SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
+**
+ ROSH = 0.1D0
+ BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
+ & +0.25D0*LOG(S/(AMV2+SQ2)))
+* coherence length
+ IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
+ ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
+ & BSLOPE,0)
+ ELSE
+ BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
+ ENDIF
+ IF (ECMNOW.LE.3.0D0) THEN
+ ROSH = -0.43D0
+ ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
+ ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
+ ELSEIF (ECMNOW.GT.50.0D0) THEN
+ ROSH = 0.1D0
+ ENDIF
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
+ & BDUM,0)
+ SIGSH = SIGSH/10.0D0
+ ELSE
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+ ELSE
+ BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
+ ROSH = 0.01D0
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+ GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
+ GAM = GSH
+ RCA = GAM*SIGSH/TWOPI
+ FCA = -ROSH*RCA
+ CA = DCMPLX(RCA,FCA)
+ CI = DCMPLX(ONE,ZERO)
+
+ 16 CONTINUE
+* impact parameter
+ IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
+
+ NTRY = 0
+ 3 CONTINUE
+ NTRY = NTRY+1
+* initializations
+ JNT = 0
+ DO 1 I=1,NA
+ JS(I) = 0
+ 1 CONTINUE
+ DO 2 I=1,NB
+ JT(I) = 0
+ 2 CONTINUE
+ IF (IJPROJ.EQ.7) THEN
+ DO 8 I=1,MAXNCL
+ JS0(I) = 0
+ JNT0(I)= 0
+ DO 9 J=1,NB
+ JT0(I,J) = 0
+ 9 CONTINUE
+ 8 CONTINUE
+ ENDIF
+
+* nucleon configuration
+C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
+ IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
+C CALL DT_CONUCL(PKOO,NA,RASH,2)
+C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
+ IF (NIDX.LE.-1) THEN
+ CALL DT_CONUCL(PKOO,NA,RASH(1),0)
+ CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
+ ELSE
+ CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
+ ENDIF
+ NTARGO = NTARG
+ ENDIF
+ ICNT = ICNT+1
+
+* LEPTO: pick out one struck nucleon
+ IF (MCGENE.EQ.3) THEN
+ JNT = 1
+ JS(1) = 1
+ IDX = INT(DT_RNDM(X)*NB)+1
+ JT(IDX) = 1
+ B = ZERO
+ GOTO 19
+ ENDIF
+
+ DO 4 INA=1,NA
+* cross section fluctuations
+ AFLUC = ONE
+ IF (IFLUCT.EQ.1) THEN
+ IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
+ AFLUC = FLUIXX(IFLUK)
+ ENDIF
+ KK1 = 1
+ KINT = 1
+ DO 5 INB=1,NB
+* photon-projectile: check for supression by coherence length
+ IF (IJPROJ.EQ.7) THEN
+ IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
+ KK1 = INB
+ KINT = KINT+1
+ ENDIF
+ ENDIF
+ QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
+ QQ2 = TKOO(2,INB)-PKOO(2,INA)
+ XY = GAM*(QQ1*QQ1+QQ2*QQ2)
+ IF (XY.LE.15.0D0) THEN
+ C = CI-CA*AFLUC*EXP(-XY)
+ AR = DBLE(C)
+ AI = DIMAG(C)
+ P = AR*AR+AI*AI
+ IF (DT_RNDM(XY).GE.P) THEN
+ JNT = JNT+1
+ IF (IJPROJ.EQ.7) THEN
+ JNT0(KINT) = JNT0(KINT)+1
+ IF (JNT0(KINT).GT.MAXNCL) THEN
+ WRITE(LOUT,1001) MAXNCL
+ 1001 FORMAT(1X,
+ & 'DIAGR: no. of requested interactions',
+ & ' exceeds array dimensions ',I4)
+ STOP
+ ENDIF
+ JS0(KINT) = JS0(KINT)+1
+ JT0(KINT,INB) = JT0(KINT,INB)+1
+ JI1(KINT,JNT0(KINT)) = INA
+ JI2(KINT,JNT0(KINT)) = INB
+ ELSE
+ IF (JNT.GT.MAXINT) THEN
+ WRITE(LOUT,1000) JNT, MAXINT
+ 1000 FORMAT(1X,
+ & 'DIAGR: no. of requested interactions ('
+ & ,I4,') exceeds array dimensions (',I4,')')
+ STOP
+ ENDIF
+ JS(INA) = JS(INA)+1
+ JT(INB) = JT(INB)+1
+ INTER1(JNT) = INA
+ INTER2(JNT) = INB
+ ENDIF
+ ENDIF
+ ENDIF
+ 5 CONTINUE
+ 4 CONTINUE
+
+ IF (JNT.EQ.0) THEN
+ IF (NTRY.LT.500) THEN
+ GOTO 3
+ ELSE
+C WRITE(6,*) ' new impact parameter required (old= ',B,')'
+ GOTO 16
+ ENDIF
+ ENDIF
+
+ IDIREC = 0
+ IF (IJPROJ.EQ.7) THEN
+ K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
+ 10 CONTINUE
+ IF (JNT0(K).EQ.0) THEN
+ K = K+1
+ IF (K.GT.KINT) K = 1
+ GOTO 10
+ ENDIF
+* supress Glauber-cascade by direct photon processes
+ CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
+ IF (IPNT.GT.0) THEN
+ JNT = 1
+ JS(1) = 1
+ DO 11 INB=1,NB
+ JT(INB) = JT0(K,INB)
+ IF (JT(INB).GT.0) GOTO 12
+ 11 CONTINUE
+ 12 CONTINUE
+ INTER1(1) = 1
+ INTER2(1) = INB
+ IDIREC = IPNT
+ ELSE
+ JNT = JNT0(K)
+ JS(1) = JS0(K)
+ DO 13 INB=1,NB
+ JT(INB) = JT0(K,INB)
+ 13 CONTINUE
+ DO 14 I=1,JNT
+ INTER1(I) = JI1(K,I)
+ INTER2(I) = JI2(K,I)
+ 14 CONTINUE
+ ENDIF
+ ENDIF
+
+ 19 CONTINUE
+ INTA = 0
+ INTB = 0
+ DO 6 I=1,NA
+ IF (JS(I).NE.0) INTA=INTA+1
+ 6 CONTINUE
+ DO 7 I=1,NB
+ IF (JT(I).NE.0) INTB=INTB+1
+ 7 CONTINUE
+ ICWPG = INTA
+ ICWTG = INTB
+ ICIG = JNT
+ IPGLB = IPGLB+INTA
+ ITGLB = ITGLB+INTB
+ NGLB = NGLB+1
+
+ IF (NCOMPO.EQ.0) THEN
+ NCALL = NCALL+1
+ NWA(INTA) = NWA(INTA)+1
+ NWB(INTB) = NWB(INTB)+1
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_MODB.FOR
+*COPY DT_MODB
+*
+*===modb===============================================================*
+*
+ SUBROUTINE DT_MODB(B,NIDX)
+
+************************************************************************
+* Sampling of impact parameter of collision. *
+* B impact parameter (output) *
+* NIDX index of projectile/target material (input)*
+* Based on the original version by Shmakov et al. *
+* This version dated 21.04.95 is revised by S. Roesler *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
+
+ LOGICAL LEFT,LFIRST
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ DATA LFIRST /.TRUE./
+
+ NTARG = ABS(NIDX)
+ IF (NIDX.LE.-1) THEN
+ RA = RASH(1)
+ RB = RBSH(NTARG)
+ ELSE
+ RA = RASH(NTARG)
+ RB = RBSH(1)
+ ENDIF
+
+ IF (ICENTR.EQ.2) THEN
+ IF (RA.EQ.RB) THEN
+ BB = DT_RNDM(B)*(0.3D0*RA)**2
+ B = SQRT(BB)
+ ELSEIF(RA.LT.RB)THEN
+ BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
+ B = SQRT(BB)
+ ELSEIF(RA.GT.RB)THEN
+ BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
+ B = SQRT(BB)
+ ENDIF
+ ELSE
+ 9 CONTINUE
+ Y = DT_RNDM(BB)
+ I0 = 1
+ I2 = NSITEB
+ 10 CONTINUE
+ I1 = (I0+I2)/2
+ LEFT = ((BSITE(0,1,NTARG,I0)-Y)
+ & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
+ IF (LEFT) GOTO 20
+ I0 = I1
+ GOTO 30
+ 20 CONTINUE
+ I2 = I1
+ 30 CONTINUE
+ IF (I2-I0-2) 40,50,60
+ 40 CONTINUE
+ I1 = I2+1
+ IF (I1.GT.NSITEB) I1 = I0-1
+ GOTO 70
+ 50 CONTINUE
+ I1 = I0+1
+ GOTO 70
+ 60 CONTINUE
+ GOTO 10
+ 70 CONTINUE
+ X0 = DBLE(I0-1)*BSTEP(NTARG)
+ X1 = DBLE(I1-1)*BSTEP(NTARG)
+ X2 = DBLE(I2-1)*BSTEP(NTARG)
+ Y0 = BSITE(0,1,NTARG,I0)
+ Y1 = BSITE(0,1,NTARG,I1)
+ Y2 = BSITE(0,1,NTARG,I2)
+ 80 CONTINUE
+ B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
+ & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
+ & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
+**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
+ B = B+0.5D0*BSTEP(NTARG)
+ IF (B.LT.ZERO) B = X1
+ IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
+ IF (ICENTR.LT.0) THEN
+ IF (LFIRST) THEN
+ LFIRST = .FALSE.
+ IF (ICENTR.LE.-100) THEN
+ BIMIN = 0.0D0
+ ELSE
+ XSFRAC = 0.0D0
+ ENDIF
+ CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
+ WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
+ & BIMIN,BIMAX,XSFRAC*100.0D0,
+ & XSFRAC*XSPRO(1,1,NTARG)
+ 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
+ & /,15X,'---------------------------'/,/,4X,
+ & 'average radii of proj / targ :',F10.3,' fm /',
+ & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
+ & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
+ & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
+ & ' cross section :',F10.3,' %',/,5X,
+ & 'corresponding cross section :',F10.3,' mb',/)
+ ENDIF
+ IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
+ B = BIMIN
+ ELSE
+ IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SHFAST.FOR
+*COPY DT_SHFAST
+*
+*===shfast=============================================================*
+*
+ SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
+ & ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ IBACK = 0
+
+ IF (MODE.EQ.2) THEN
+ OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
+ WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
+ 1000 FORMAT(1X,8I5,E15.5)
+ WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
+ 1001 FORMAT(1X,4E15.5)
+ WRITE(47,1002) SIGSH,ROSH,GSH
+ 1002 FORMAT(1X,3E15.5)
+ DO 10 I=1,100
+ WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
+ 10 CONTINUE
+ WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
+ 1003 FORMAT(1X,2I10,3E15.5)
+ CLOSE(47)
+ ELSE
+ OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
+ READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
+ IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
+ & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
+ & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
+ & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
+ READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
+ READ(47,1002) SIGSH,ROSH,GSH
+ DO 11 I=1,100
+ READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
+ 11 CONTINUE
+ READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
+ ELSE
+ IBACK = 1
+ ENDIF
+ CLOSE(47)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_POILIK.FOR
+*COPY DT_POILIK
+*
+*===poilik=============================================================*
+*
+ SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
+ PARAMETER (NE = 8)
+
+**PHOJET105a
+C CHARACTER*8 MDLNA
+C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+**sr 22.7.97
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+**
+
+ DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
+
+ IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
+
+* load cross sections from interpolation table
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+
+ SIGANO = DT_SANO(ECM)
+
+* cross section dependence on photon virtuality
+ FSUP1 = ZERO
+ DO 150 I=1,3
+ FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
+ & /(ONE+VIRT/PARMDL(30+I))**2
+ 150 CONTINUE
+ FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
+ FAC1 = FAC1*FSUP1
+ FAC2 = FAC2*FSUP1
+ FSUP2 = ONE
+
+ ECMOLD = ECM
+ Q2OLD = VIRT
+
+ 3 CONTINUE
+
+C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
+ IF (ISHAD(1).EQ.1) THEN
+ SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+ ELSE
+ SIGDIR = ZERO
+ ENDIF
+ SIGANO = FSUP1*FSUP2*SIGANO
+ SIGTOT = SIGTOT-SIGDIR-SIGANO
+ SIGDIR = SIGDIR/(FSUP1*FSUP2)
+ SIGANO = SIGANO/(FSUP1*FSUP2)
+ SIGTOT = SIGTOT+SIGDIR+SIGANO
+
+ RR = DT_RNDM(SIGTOT)
+ IF (RR.LT.SIGDIR/SIGTOT) THEN
+ IPNT = 1
+ ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
+ & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
+ IPNT = 2
+ ELSE
+ IPNT = 0
+ ENDIF
+ RPNT = (SIGDIR+SIGANO)/SIGTOT
+C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
+C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
+C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
+C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
+ IF (MODE.EQ.1) RETURN
+
+**sr 22.7.97
+ K1 = 1
+ K2 = 1
+ RATE = ZERO
+ IF (ECM.GE.ECMNN(NEBINI)) THEN
+ K1 = NEBINI
+ K2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECM.GT.ECMNN(1)) THEN
+ DO 10 I=2,NEBINI
+ IF (ECM.LT.ECMNN(I)) THEN
+ K1 = I-1
+ K2 = I
+ RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
+ GOTO 11
+ ENDIF
+ 10 CONTINUE
+ 11 CONTINUE
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ZERO
+ IF (NQBINI.GT.1) THEN
+ IF (VIRT.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (VIRT.GT.Q2G(1)) THEN
+ DO 12 I=2,NQBINI
+ IF (VIRT.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+ GOTO 13
+ ENDIF
+ 12 CONTINUE
+ 13 CONTINUE
+ ENDIF
+ ENDIF
+ SGA = XSPRO(K1,J1,NTARG)+
+ & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
+ & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
+ & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
+ & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
+ SDI = DBLE(NB)*SIGDIR
+ SAN = DBLE(NB)*SIGANO
+ SPL = SDI+SAN
+ RR = DT_RNDM(SPL)
+ IF (RR.LT.SDI/SGA) THEN
+ IPNT = 1
+ ELSEIF ((RR.GE.SDI/SGA).AND.
+ & (RR.LT.SPL/SGA)) THEN
+ IPNT = 2
+ ELSE
+ IPNT = 0
+ ENDIF
+ RPNT = SPL/SGA
+C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
+**
+
+ RETURN
+ END
+
+*$ CREATE DT_GLBINI.FOR
+*COPY DT_GLBINI
+*
+*===glbini=============================================================*
+*
+ SUBROUTINE DT_GLBINI(WHAT)
+
+************************************************************************
+* Pre-initialization of profile function *
+* This version dated 28.11.00 is written by S. Roesler. *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
+
+ LOGICAL LCMS
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+* number of data sets other than protons and nuclei
+* at the moment = 2 (pions and kaons)
+ PARAMETER (MAXOFF=2)
+ DIMENSION IJPINI(5),IOFFST(25)
+ DATA IJPINI / 13, 15, 0, 0, 0/
+* Glauber data-set to be used for hadron projectiles
+* (0=proton, 1=pion, 2=kaon)
+ DATA (IOFFST(K),K=1,25) /
+ & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
+ & 0, 0, 1, 2, 2/
+* Acceptance interval for target nucleus mass
+ PARAMETER (KBACC = 6)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ PARAMETER (MAXMSS = 100)
+ DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
+ DIMENSION WHAT(6)
+
+ DATA JPEACH,JPSTEP / 18, 5 /
+
+* temporary patch until fix has been implemented in phojet:
+* maximum energy for pion projectile
+ DATA ECMXPI / 100000.0D0 /
+*
+*--------------------------------------------------------------------------
+* general initializations
+*
+* steps in projectile mass number for initialization
+ IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
+ IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
+*
+* energy range and binning
+ ELO = ABS(WHAT(1))
+ EHI = ABS(WHAT(2))
+ IF (ELO.GT.EHI) ELO = EHI
+ NEBIN = MAX(INT(WHAT(3)),1)
+ IF (ELO.EQ.EHI) NEBIN = 0
+ LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
+ IF (LCMS) THEN
+ ECMINI = EHI
+ ELSE
+ ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
+ & +2.0D0*AAM(IJTARG)*EHI)
+ ENDIF
+*
+* default arguments for Glauber-routine
+ XI = ZERO
+ Q2I = ZERO
+*
+* initialize nuclear parameters, etc.
+
+* initialize evaporation if the code is not used as Fluka event generator
+ IF (ITRSPT.NE.1) THEN
+ CALL NCDTRD
+ CALL INCINI
+ ENDIF
+
+*
+* open Glauber-data output file
+ IDX = INDEX(CGLB,' ')
+ K = 12
+ IF (IDX.GT.1) K = IDX-1
+ OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
+*
+*--------------------------------------------------------------------------
+* Glauber-initialization for proton and nuclei projectiles
+*
+* initialize phojet for proton-proton interactions
+ ELAB = ZERO
+ PLAB = ZERO
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
+ CALL DT_PHOINI
+*
+* record projectile masses
+ NASAV = 0
+ NPROJ = MIN(IP,JPEACH)
+ DO 10 KPROJ=1,NPROJ
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = KPROJ
+ 10 CONTINUE
+ IF (IP.GT.JPEACH) THEN
+ NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
+ IF (NPROJ.EQ.0) THEN
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = IP
+ ELSE
+ DO 11 IPROJ=1,NPROJ
+ KPROJ = JPEACH+IPROJ*JPSTEP
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = KPROJ
+ 11 CONTINUE
+ IF (KPROJ.LT.IP) THEN
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = IP
+ ENDIF
+ ENDIF
+ ENDIF
+*
+* record target masses
+ NBSAV = 0
+ NTARG = 1
+ IF (NCOMPO.GT.0) NTARG = NCOMPO
+ DO 12 ITARG=1,NTARG
+ NBSAV = NBSAV+1
+ IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
+ IF (NCOMPO.GT.0) THEN
+ IBSAV(NBSAV) = IEMUMA(ITARG)
+ ELSE
+ IBSAV(NBSAV) = IT
+ ENDIF
+ 12 CONTINUE
+*
+* print masses
+ WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
+ 1000 FORMAT(I4,A,1P,2E13.5)
+ NLINES = DBLE(NASAV)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 13 I=1,NLINES
+ IF (I.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
+ ENDIF
+ 13 CONTINUE
+ ENDIF
+ I0 = 18*NLINES+1
+ IF (I0.LE.NASAV) THEN
+ IF (I0.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
+ ENDIF
+ ENDIF
+ NLINES = DBLE(NBSAV)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 14 I=1,NLINES
+ IF (I.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
+ ENDIF
+ 14 CONTINUE
+ ENDIF
+ I0 = 18*NLINES+1
+ IF (I0.LE.NBSAV) THEN
+ IF (I0.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
+ ENDIF
+ ENDIF
+*
+* calculate Glauber-data for each energy and mass combination
+*
+* loop over energy bins
+ ELO = LOG10(ELO)
+ EHI = LOG10(EHI)
+ DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
+ DO 1 IE=1,NEBIN+1
+ E = ELO+DBLE(IE-1)*DEBIN
+ E = 10**E
+ IF (LCMS) THEN
+ E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
+ ECM = E
+ ELSE
+ PLAB = ZERO
+ ECM = ZERO
+ E = MAX(AAM(IJPROJ)+0.1D0,E)
+ CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
+ ENDIF
+*
+* loop over projectile and target masses
+ DO 2 ITARG=1,NBSAV
+ DO 3 IPROJ=1,NASAV
+ CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
+ & XI,Q2I,ECM,1,1,-1)
+ 3 CONTINUE
+ 2 CONTINUE
+*
+ 1 CONTINUE
+*
+*--------------------------------------------------------------------------
+* Glauber-initialization for pion, kaon, ... projectiles
+*
+ DO 6 IJ=1,MAXOFF
+*
+* initialize phojet for this interaction
+ ELAB = ZERO
+ PLAB = ZERO
+ IJPROJ = IJPINI(IJ)
+ IP = 1
+ IPZ = 1
+*
+* temporary patch until fix has been implemented in phojet:
+ IF (ECMINI.GT.ECMXPI) THEN
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
+ ELSE
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
+ ENDIF
+ CALL DT_PHOINI
+*
+* calculate Glauber-data for each energy and mass combination
+*
+* loop over energy bins
+ DO 4 IE=1,NEBIN+1
+ E = ELO+DBLE(IE-1)*DEBIN
+ E = 10**E
+ IF (LCMS) THEN
+ E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
+ ECM = E
+ ELSE
+ PLAB = ZERO
+ ECM = ZERO
+ E = MAX(AAM(IJPROJ)+TINY14,E)
+ CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
+ ENDIF
+*
+* loop over projectile and target masses
+ DO 5 ITARG=1,NBSAV
+ CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
+ 5 CONTINUE
+*
+ 4 CONTINUE
+*
+ 6 CONTINUE
+
+*--------------------------------------------------------------------------
+* close output unit(s), etc.
+*
+ CLOSE(LDAT)
+
+ RETURN
+ END
+
+*$ CREATE DT_GLBSET.FOR
+*COPY DT_GLBSET
+*
+*===glbset=============================================================*
+*
+ SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
+************************************************************************
+* Interpolation of pre-initialized profile functions *
+* This version dated 28.11.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0)
+
+ LOGICAL LCMS,LREAD,LFRST1,LFRST2
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* number of data sets other than protons and nuclei
+* at the moment = 2 (pions and kaons)
+ PARAMETER (MAXOFF=2)
+ DIMENSION IJPINI(5),IOFFST(25)
+ DATA IJPINI / 13, 15, 0, 0, 0/
+* Glauber data-set to be used for hadron projectiles
+* (0=proton, 1=pion, 2=kaon)
+ DATA (IOFFST(K),K=1,25) /
+ & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
+ & 0, 0, 1, 2, 2/
+* Acceptance interval for target nucleus mass
+ PARAMETER (KBACC = 6)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+ PARAMETER (MAXSET=5000,
+ & MAXBIN=100)
+ DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
+ DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
+ & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
+ & IAIDX(10)
+
+ DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
+*
+* read data from file
+*
+ IF (MODE.EQ.0) THEN
+
+ IF (LREAD) RETURN
+
+ DO 1 I=1,MAXSET
+ DO 2 J=1,6
+ XSIG(I,J) = ZERO
+ XERR(I,J) = ZERO
+ 2 CONTINUE
+ DO 3 J=1,KSITEB
+ BPROFL(I,J) = ZERO
+ 3 CONTINUE
+ 1 CONTINUE
+ DO 4 I=1,MAXBIN
+ IABIN(I) = 0
+ IBBIN(I) = 0
+ 4 CONTINUE
+ DO 5 I=1,KSITEB
+ BPRO0(I) = ZERO
+ BPRO1(I) = ZERO
+ BPRO(I) = ZERO
+ 5 CONTINUE
+
+ IDX = INDEX(CGLB,' ')
+ K = 12
+ IF (IDX.GT.1) K = IDX-1
+ OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
+ WRITE(LOUT,1000) CGLB(1:K)//'.glb'
+ 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
+ & 'file ',A12,/)
+*
+* read binning information
+ READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
+* return lower energy threshold to Fluka-interface
+ ELAB = ELO
+ LCMS = ELO.LT.ZERO
+ WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
+ IF (LCMS) THEN
+ WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
+ ELSE
+ WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
+ ENDIF
+ 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
+ & 'No. of bins:',I5,/)
+ ELO = LOG10(ABS(ELO))
+ EHI = LOG10(ABS(EHI))
+ DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
+ WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
+ READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
+ IF (NABIN.LT.18) THEN
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
+ ELSE
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
+ ENDIF
+ IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
+ IF (NABIN.GT.18) THEN
+ NLINES = DBLE(NABIN-18)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 7 I=1,NLINES
+ I0 = 18*(I+1)-17
+ READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
+ 7 CONTINUE
+ ENDIF
+ I0 = 18*(NLINES+1)+1
+ IF (I0.LE.NABIN) THEN
+ READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
+ ENDIF
+ ENDIF
+ WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
+ READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
+ IF (NBBIN.LT.18) THEN
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
+ ELSE
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
+ ENDIF
+ IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
+ IF (NBBIN.GT.18) THEN
+ NLINES = DBLE(NBBIN-18)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 8 I=1,NLINES
+ I0 = 18*(I+1)-17
+ READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
+ 8 CONTINUE
+ ENDIF
+ I0 = 18*(NLINES+1)+1
+ IF (I0.LE.NBBIN) THEN
+ READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
+ ENDIF
+ ENDIF
+* number of data sets to follow in the Glauber data file
+* this variable is used for checks of consistency of projectile
+* and target mass configurations given in header of Glauber data
+* file and the data-sets which follow in this file
+ NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
+*
+* read profile function data
+ NSET = 0
+ NAIDX = 0
+ IPOLD = 0
+ 10 CONTINUE
+ NSET = NSET+1
+ IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
+ READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
+ 1002 FORMAT(5I10,E15.5)
+ IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
+ NAIDX = NAIDX+1
+ IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
+ IAIDX(NAIDX) = IP
+ IPOLD = IP
+ ENDIF
+ READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
+ READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
+ NLINES = INT(DBLE(ISITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 11 I=1,NLINES
+ READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
+ 11 CONTINUE
+ ENDIF
+ I0 = 7*NLINES+1
+ IF (I0.LE.ISITEB)
+ & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
+ GOTO 10
+ 100 CONTINUE
+ NSET = NSET-1
+ IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
+ WRITE(LOUT,'(/,1X,A)')
+ & ' projectiles other than protons and nuclei: (particle index)'
+ IF (NAIDX.GT.0) THEN
+ WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
+ ELSE
+ WRITE(LOUT,'(6X,A)') 'none'
+ ENDIF
+*
+ CLOSE(LDAT)
+ WRITE(LOUT,*)
+ LREAD = .TRUE.
+
+ IF (NCOMPO.EQ.0) THEN
+ DO 12 J=1,NBBIN
+ NCOMPO = NCOMPO+1
+ IEMUMA(NCOMPO) = IBBIN(J)
+ IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
+ EMUFRA(NCOMPO) = 1.0D0
+ 12 CONTINUE
+ IEMUL = 1
+ ENDIF
+*
+* calculate profile function for certain set of parameters
+*
+ ELSE
+
+c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
+*
+* check for type of projectile and set index-offset to entry in
+* Glauber data array correspondingly
+ IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
+ IF (IOFFST(IDPROJ).EQ.-1) THEN
+ STOP ' GLBSET: no data for this projectile !'
+ ELSEIF (IOFFST(IDPROJ).GT.0) THEN
+ IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
+ ELSE
+ IDXOFF = 0
+ ENDIF
+*
+* get energy bin and interpolation factor
+ IF (LCMS) THEN
+ E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
+ ELSE
+ E = ELAB
+ ENDIF
+ E = LOG10(E)
+ IF (E.LT.ELO) THEN
+ IF (LFRST1) THEN
+ WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
+ LFRST1 = .FALSE.
+ ENDIF
+ E = ELO
+ ENDIF
+ IF (E.GT.EHI) THEN
+ IF (LFRST2) THEN
+ WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
+ LFRST2 = .FALSE.
+ ENDIF
+ E = EHI
+ ENDIF
+ IE0 = (E-ELO)/DEBIN+1
+ IE1 = IE0+1
+ FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
+*
+* get target nucleus index
+ KB = 0
+ NBACC = KBACC
+ DO 20 I=1,NBBIN
+ NBDIFF = ABS(NB-IBBIN(I))
+ IF (NB.EQ.IBBIN(I)) THEN
+ KB = I
+ GOTO 21
+ ELSEIF (NBDIFF.LE.NBACC) THEN
+ KB = I
+ NBACC = NBDIFF
+ ENDIF
+ 20 CONTINUE
+ IF (KB.NE.0) GOTO 21
+ WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
+ STOP
+ 21 CONTINUE
+*
+* get projectile nucleus bin and interpolation factor
+ KA0 = 0
+ KA1 = 0
+ FACNA = 0
+ IF (IDXOFF.GT.0) THEN
+ KA0 = 1
+ KA1 = 1
+ KABIN = 1
+ ELSE
+ IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
+ DO 22 I=1,NABIN
+ IF (NA.EQ.IABIN(I)) THEN
+ KA0 = I
+ KA1 = I
+ GOTO 23
+ ELSEIF (NA.LT.IABIN(I)) THEN
+ KA0 = I-1
+ KA1 = I
+ GOTO 23
+ ENDIF
+ 22 CONTINUE
+ WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
+ STOP
+ 23 CONTINUE
+ IF (KA0.NE.KA1)
+ & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
+ KABIN = NABIN
+ ENDIF
+*
+* interpolate profile functions for interactions ka0-kb and ka1-kb
+* for energy E separately
+ IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
+ IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
+ IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
+ IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
+ DO 30 I=1,ISITEB
+ BPRO0(I) = BPROFL(IDX0,I)
+ & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
+ BPRO1(I) = BPROFL(IDY0,I)
+ & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
+ 30 CONTINUE
+ RADB = DT_RNCLUS(NB)
+ BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
+ BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
+*
+* interpolate cross sections for energy E and projectile mass
+ DO 31 I=1,6
+ XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
+ XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
+ XS(I) = XS0+FACNA*(XS1-XS0)
+ XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
+ XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
+ XE(I) = XE0+FACNA*(XE1-XE0)
+ 31 CONTINUE
+*
+* interpolate between ka0 and ka1
+ RADA = DT_RNCLUS(NA)
+ BMX = 2.0D0*(RADA+RADB)
+ BSTP = BMX/DBLE(ISITEB-1)
+ BPRO(1) = ZERO
+ DO 32 I=1,ISITEB-1
+ B = DBLE(I)*BSTP
+*
+* calculate values of profile functions at B
+ IDX0 = B/BSTP0+1
+ IF (IDX0.GT.ISITEB) IDX0 = ISITEB
+ IDX1 = MIN(IDX0+1,ISITEB)
+ FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
+ BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
+ IDX0 = B/BSTP1+1
+ IF (IDX0.GT.ISITEB) IDX0 = ISITEB
+ IDX1 = MIN(IDX0+1,ISITEB)
+ FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
+ BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
+*
+ BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
+ 32 CONTINUE
+*
+* fill common dtglam
+ NSITEB = ISITEB
+ RASH(1) = RADA
+ RBSH(1) = RADB
+ BMAX(1) = BMX
+ BSTEP(1) = BSTP
+ DO 33 I=1,KSITEB
+ BSITE(0,1,1,I) = BPRO(I)
+ 33 CONTINUE
+*
+* fill common dtglxs
+ XSTOT(1,1,1) = XS(1)
+ XSELA(1,1,1) = XS(2)
+ XSQEP(1,1,1) = XS(3)
+ XSQET(1,1,1) = XS(4)
+ XSQE2(1,1,1) = XS(5)
+ XSPRO(1,1,1) = XS(6)
+ XETOT(1,1,1) = XE(1)
+ XEELA(1,1,1) = XE(2)
+ XEQEP(1,1,1) = XE(3)
+ XEQET(1,1,1) = XE(4)
+ XEQE2(1,1,1) = XE(5)
+ XEPRO(1,1,1) = XE(6)
+
+ ENDIF
+
+ RETURN
+ END
+*$ CREATE DT_XKSAMP.FOR
+*COPY DT_XKSAMP
+*
+*===xksamp=============================================================*
+*
+ SUBROUTINE DT_XKSAMP(NN,ECM)
+
+************************************************************************
+* Sampling of parton x-values and chain system for one interaction. *
+* processed by S. Roesler, 9.8.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
+ SAVE
+
+ PARAMETER (
+* lower cuts for (valence-sea/sea-valence) chain masses
+* antiquark-quark (u/d-sea quark) (s-sea quark)
+ & AMIU = 0.5D0, AMIS = 0.8D0,
+* quark-diquark (u/d-sea quark) (s-sea quark)
+ & AMAU = 2.6D0, AMAS = 2.6D0,
+* maximum lower valence-x threshold
+ & XVMAX = 0.98D0,
+* fraction of sea-diquarks sampled out of sea-partons
+**test
+C & FRCDIQ = 0.9D0,
+**
+*
+ & SQMA = 0.7D0,
+*
+* maximum number of trials to generate x's for the required number
+* of sea quark pairs for a given hadron
+ & NSEATY = 12
+C & NSEATY = 3
+ & )
+
+ LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* interface between Glauber formalism and DPM
+ COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
+ & INTER1(MAXINT),INTER2(MAXINT)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+
+* x-values of partons (DTUNUC 1.x)
+ COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
+ & XTVQ(MAXVQU),XTVD(MAXVQU),
+ & XPSQ(MAXSQU),XPSAQ(MAXSQU),
+ & XTSQ(MAXSQU),XTSAQ(MAXSQU)
+
+* flavors of partons (DTUNUC 1.x)
+ COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+ & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+ & IPSQ(MAXSQU),IPSQ2(MAXSQU),
+ & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+ & ITSQ(MAXSQU),ITSQ2(MAXSQU),
+ & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+ & KKPROJ(MAXVQU),KKTARG(MAXVQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+ & IXPV,IXPS,IXTV,IXTS,
+ & INTVV1(MAXVQU),INTVV2(MAXVQU),
+ & INTSV1(MAXVQU),INTSV2(MAXVQU),
+ & INTVS1(MAXVQU),INTVS2(MAXVQU),
+ & INTSS1(MAXSQU),INTSS2(MAXSQU),
+ & INTDV1(MAXVQU),INTDV2(MAXVQU),
+ & INTVD1(MAXVQU),INTVD2(MAXVQU),
+ & INTDS1(MAXSQU),INTDS2(MAXSQU),
+ & INTSD1(MAXSQU),INTSD2(MAXSQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+ & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
+ & INTLO(MAXINT)
+
+* (1) initializations
+*-----------------------------------------------------------------------
+
+**test
+ IF (ECM.LT.4.5D0) THEN
+C FRCDIQ = 0.6D0
+ FRCDIQ = 0.4D0
+ ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
+C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
+ FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
+ ELSE
+C FRCDIQ = 0.9D0
+ FRCDIQ = 0.7D0
+ ENDIF
+**
+ DO 30 I=1,MAXSQU
+ ZUOSP(I) = .FALSE.
+ ZUOST(I) = .FALSE.
+ IF (I.LE.MAXVQU) THEN
+ ZUOVP(I) = .FALSE.
+ ZUOVT(I) = .FALSE.
+ ENDIF
+ 30 CONTINUE
+
+* lower thresholds for x-selection
+* sea-quarks (default: CSEA=0.2)
+ IF (ECM.LT.10.0D0) THEN
+**!!test
+ XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
+C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
+ NSEA = NSEATY
+C XSTHR = ONE/ECM**2
+ ELSE
+**sr 30.3.98
+C XSTHR = CSEA/ECM
+ XSTHR = CSEA/ECM**2
+C XSTHR = ONE/ECM**2
+**
+ IF ((IP.GE.150).AND.(IT.GE.150))
+ & XSTHR = 2.5D0/(ECM*SQRT(ECM))
+ NSEA = NSEATY
+ ENDIF
+* (default: SSMIMA=0.14) used for sea-diquarks (?)
+ XSSTHR = SSMIMA/ECM
+ BSQMA = SQMA/ECM
+* valence-quarks (default: CVQ=1.0)
+ XVTHR = CVQ/ECM
+* valence-diquarks (default: CDQ=2.0)
+ XDTHR = CDQ/ECM
+
+* maximum-x for sea-quarks
+ XVCUT = XVTHR+XDTHR
+ IF (XVCUT.GT.XVMAX) THEN
+ XVCUT = XVMAX
+ XVTHR = XVCUT/3.0D0
+ XDTHR = XVCUT-XVTHR
+ ENDIF
+ XXSEAM = ONE-XVCUT
+**sr 18.4. test: DPMJET
+C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
+C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
+C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
+**
+* maximum number of sea-pairs allowed kinematically
+C NSMAX = INT(OHALF*XXSEAM/XSTHR)
+ RNSMAX = OHALF*XXSEAM/XSTHR
+ IF (RNSMAX.GT.10000.0D0) THEN
+ NSMAX = 10000
+ ELSE
+ NSMAX = INT(OHALF*XXSEAM/XSTHR)
+ ENDIF
+* check kinematical limit for valence-x thresholds
+* (should be obsolete now)
+ IF (XVCUT.GT.XVMAX) THEN
+ WRITE(LOUT,1000) XVCUT,ECM
+ 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
+ & ' thresholds not allowed (',2E9.3,')')
+C XVTHR = XVMAX-XDTHR
+C IF (XVTHR.LT.ZERO) STOP
+ STOP
+ ENDIF
+
+* set eta for valence-x sampling (BETREJ)
+* (UNON per default, UNOM used for projectile mesons only)
+ IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
+ UNOPRV = UNOM
+ ELSE
+ UNOPRV = UNON
+ ENDIF
+
+* (2) select parton x-values of interacting projectile nucleons
+*-----------------------------------------------------------------------
+
+ IXPV = 0
+ IXPS = 0
+
+ DO 100 IPP=1,IP
+* get interacting projectile nucleon as sampled by Glauber
+ IF (JSSH(IPP).NE.0) THEN
+ IXSTMP = IXPS
+ IXVTMP = IXPV
+ 99 CONTINUE
+ IXPS = IXSTMP
+ IXPV = IXVTMP
+* JIPP is the actual number of sea-pairs sampled for this nucleon
+ JIPP = MIN(JSSH(IPP)-1,NSMAX)
+ 41 CONTINUE
+ XXSEA = ZERO
+ IF (JIPP.GT.0) THEN
+ XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
+*???
+ IF (XSTHR.GE.XSMAX) THEN
+ JIPP = JIPP-1
+ GOTO 41
+ ENDIF
+
+*>>>get x-values of sea-quark pairs
+ NSCOUN = 0
+ PLW = 0.5D0
+ 40 CONTINUE
+* accumulator for sea x-values
+ XXSEA = ZERO
+ NSCOUN = NSCOUN+1
+ IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
+ IF (NSCOUN.GT.NSEA) THEN
+* decrease the number of interactions after NSEA trials
+ JIPP = JIPP-1
+ NSCOUN = 0
+ ENDIF
+ DO 70 ISQ=1,JIPP
+* sea-quarks
+ IF (IPSQ(IXPS+1).LE.2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+* sea-antiquarks
+ IF (IPSAQ(IXPS+1).GE.-2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+ XXSEA = XXSEA+XPSQI+XPSAQI
+* check for maximum allowed sea x-value
+ IF (XXSEA.GE.XXSEAM) THEN
+ IXPS = IXPS-ISQ+1
+ GOTO 40
+ ENDIF
+* accept this sea-quark pair
+ IXPS = IXPS+1
+ XPSQ(IXPS) = XPSQI
+ XPSAQ(IXPS) = XPSAQI
+ IFROSP(IXPS) = IPP
+ ZUOSP(IXPS) = .TRUE.
+ 70 CONTINUE
+ ENDIF
+
+*>>>get x-values of valence partons
+* valence quark
+ IF (XVTHR.GT.0.05D0) THEN
+ XVHI = ONE-XXSEA-XDTHR
+ XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
+ ELSE
+ 90 CONTINUE
+ XPVQI = DT_DBETAR(OHALF,UNOPRV)
+ IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
+ & GOTO 90
+ ENDIF
+* valence diquark
+ XPVDI = ONE-XPVQI-XXSEA
+* reject according to x**1.5
+ XDTMP = XPVDI**1.5D0
+ IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
+* accept these valence partons
+ IXPV = IXPV+1
+ XPVQ(IXPV) = XPVQI
+ XPVD(IXPV) = XPVDI
+ IFROVP(IXPV) = IPP
+ ITOVP(IPP) = IXPV
+ ZUOVP(IXPV) = .TRUE.
+
+ ENDIF
+ 100 CONTINUE
+
+* (3) select parton x-values of interacting target nucleons
+*-----------------------------------------------------------------------
+
+ IXTV = 0
+ IXTS = 0
+
+ DO 170 ITT=1,IT
+* get interacting target nucleon as sampled by Glauber
+ IF (JTSH(ITT).NE.0) THEN
+ IXSTMP = IXTS
+ IXVTMP = IXTV
+ 169 CONTINUE
+ IXTS = IXSTMP
+ IXTV = IXVTMP
+* JITT is the actual number of sea-pairs sampled for this nucleon
+ JITT = MIN(JTSH(ITT)-1,NSMAX)
+ 111 CONTINUE
+ XXSEA = ZERO
+ IF (JITT.GT.0) THEN
+ XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
+*???
+ IF (XSTHR.GE.XSMAX) THEN
+ JITT = JITT-1
+ GOTO 111
+ ENDIF
+
+*>>>get x-values of sea-quark pairs
+ NSCOUN = 0
+ PLW = 0.5D0
+ 110 CONTINUE
+* accumulator for sea x-values
+ XXSEA = ZERO
+ NSCOUN = NSCOUN+1
+ IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
+ IF (NSCOUN.GT.NSEA)THEN
+* decrease the number of interactions after NSEA trials
+ JITT = JITT-1
+ NSCOUN = 0
+ ENDIF
+ DO 140 ISQ=1,JITT
+* sea-quarks
+ IF (ITSQ(IXTS+1).LE.2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+* sea-antiquarks
+ IF (ITSAQ(IXTS+1).GE.-2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+ XXSEA = XXSEA+XTSQI+XTSAQI
+* check for maximum allowed sea x-value
+ IF (XXSEA.GE.XXSEAM) THEN
+ IXTS = IXTS-ISQ+1
+ GOTO 110
+ ENDIF
+* accept this sea-quark pair
+ IXTS = IXTS+1
+ XTSQ(IXTS) = XTSQI
+ XTSAQ(IXTS) = XTSAQI
+ IFROST(IXTS) = ITT
+ ZUOST(IXTS) = .TRUE.
+ 140 CONTINUE
+ ENDIF
+
+*>>>get x-values of valence partons
+* valence quark
+ IF (XVTHR.GT.0.05D0) THEN
+ XVHI = ONE-XXSEA-XDTHR
+ XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
+ ELSE
+ 160 CONTINUE
+ XTVQI = DT_DBETAR(OHALF,UNON)
+ IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
+ & GOTO 160
+ ENDIF
+* valence diquark
+ XTVDI = ONE-XTVQI-XXSEA
+* reject according to x**1.5
+ XDTMP = XTVDI**1.5D0
+ IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
+* accept these valence partons
+ IXTV = IXTV+1
+ XTVQ(IXTV) = XTVQI
+ XTVD(IXTV) = XTVDI
+ IFROVT(IXTV) = ITT
+ ITOVT(ITT) = IXTV
+ ZUOVT(IXTV) = .TRUE.
+
+ ENDIF
+ 170 CONTINUE
+
+* (4) get valence-valence chains
+*-----------------------------------------------------------------------
+
+ NVV = 0
+ DO 240 I=1,NN
+ INTLO(I) = .TRUE.
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
+ INTLO(I) = .FALSE.
+ ZUOVP(IPVAL) = .FALSE.
+ ZUOVT(ITVAL) = .FALSE.
+ NVV = NVV+1
+ ISKPCH(8,NVV) = 0
+ INTVV1(NVV) = IPVAL
+ INTVV2(NVV) = ITVAL
+ ENDIF
+ 240 CONTINUE
+
+* (5) get sea-valence chains
+*-----------------------------------------------------------------------
+
+ NSV = 0
+ NDV = 0
+ PLW = 0.5D0
+ DO 270 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ DO 250 J=1,IXPS
+ IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
+ & ZUOVT(ITVAL)) THEN
+ ZUOSP(J) = .FALSE.
+ ZUOVT(ITVAL) = .FALSE.
+ INTLO(I) = .FALSE.
+ IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
+ IF (IREJ1.EQ.0) GOTO 260
+ ENDIF
+ NSV = NSV+1
+ ISKPCH(4,NSV) = 0
+ INTSV1(NSV) = J
+ INTSV2(NSV) = ITVAL
+
+*>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
+ AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
+* get lower mass cuts
+ IF (IPSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMAS
+ AMCHK2 = AMIS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMAU
+ AMCHK2 = AMIU
+ ENDIF
+* q-qq chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMSVQ1.GT.AMCHK1) THEN
+ XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
+C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
+ XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
+**
+ XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
+ XPSQ(J) = XPSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMSVQ1.LT.AMCHK1) THEN
+ XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
+ DXPSQ = XPSQW-XPSQ(J)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
+ XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
+ XPSQ(J) = XPSQW
+ ENDIF
+ ENDIF
+* aq-q chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMSVQ2.LT.AMCHK2) THEN
+ XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
+ DXPSQ = XPSQW-XPSAQ(J)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
+ XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
+ XPSAQ(J) = XPSQW
+ ENDIF
+ ENDIF
+*>>>end of chain mass correction
+
+ GOTO 260
+ ENDIF
+ 250 CONTINUE
+ ENDIF
+ 260 CONTINUE
+ 270 CONTINUE
+
+* (6) get valence-sea chains
+*-----------------------------------------------------------------------
+
+ NVS = 0
+ NVD = 0
+ DO 300 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ DO 280 J=1,IXTS
+ IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
+ & (IFROST(J).EQ.INTER2(I))) THEN
+ ZUOST(J) = .FALSE.
+ ZUOVP(IPVAL) = .FALSE.
+ INTLO(I) = .FALSE.
+ IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
+ IF (IREJ1.EQ.0) GOTO 290
+ ENDIF
+ NVS = NVS + 1
+ ISKPCH(6,NVS) = 0
+ INTVS1(NVS) = IPVAL
+ INTVS2(NVS) = J
+
+*>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
+ AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
+* get lower mass cuts
+ IF (ITSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMIS
+ AMCHK2 = AMAS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMIU
+ AMCHK2 = AMAU
+ ENDIF
+* q-aq chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMVSQ1.LT.AMCHK1) THEN
+ XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
+ DXTSQ = XTSQW-XTSAQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
+ XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
+ XTSAQ(J) = XTSQW
+ ENDIF
+ ENDIF
+* qq-q chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMVSQ2.GT.AMCHK2) THEN
+ XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
+C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
+ XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
+**
+ XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
+ XTSQ(J) = XTSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMVSQ2.LT.AMCHK2) THEN
+ XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
+ DXTSQ = XTSQW-XTSQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
+ XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
+ XTSQ(J) = XTSQW
+ ENDIF
+ ENDIF
+*>>>end of chain mass correction
+
+ GOTO 290
+ ENDIF
+ 280 CONTINUE
+ ENDIF
+ 290 CONTINUE
+ 300 CONTINUE
+
+* (7) get sea-sea chains
+*-----------------------------------------------------------------------
+
+ NSS = 0
+ NDS = 0
+ NSD = 0
+ DO 420 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+* loop over target partons not yet matched
+ DO 400 J=1,IXTS
+ IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
+* loop over projectile partons not yet matched
+ DO 390 JJ=1,IXPS
+ IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
+ ZUOSP(JJ) = .FALSE.
+ ZUOST(J) = .FALSE.
+ INTLO(I) = .FALSE.
+ NSS = NSS+1
+ ISKPCH(1,NSS) = 0
+ INTSS1(NSS) = JJ
+ INTSS2(NSS) = J
+
+*---->chain recombination option
+ VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
+ IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
+ & THEN
+* sea-sea chains may recombine with valence-valence chains
+* only if they have the same projectile or target nucleon
+ DO 4201 IVV=1,NVV
+ IF (ISKPCH(8,IVV).NE.99) THEN
+ IXVPR = INTVV1(IVV)
+ IXVTA = INTVV2(IVV)
+ IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
+ & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
+* recombination possible, drop old v-v and s-s chains
+ ISKPCH(1,NSS) = 99
+ ISKPCH(8,IVV) = 99
+
+* (a) assign new s-v chains
+* ~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (LSEADI.AND.
+ & (DT_RNDM(VALFRA).GT.FRCDIQ))
+ & THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
+ & IREJ1)
+ IF (IREJ1.EQ.0) GOTO 4202
+ ENDIF
+ NSV = NSV+1
+ ISKPCH(4,NSV) = 0
+ INTSV1(NSV) = JJ
+ INTSV2(NSV) = IXVTA
+*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
+ & *ECM**2
+ AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
+ & *ECM**2
+* get lower mass cuts
+ IF (IPSQ(JJ).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMAS
+ AMCHK2 = AMIS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMAU
+ AMCHK2 = AMIU
+ ENDIF
+* q-qq chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMSVQ1.GT.AMCHK1) THEN
+ XPSQTH =
+ & AMCHK1/(XTVD(IXVTA)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+ XPSQXX =
+ & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
+C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
+C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
+**
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
+ XPSQ(JJ) = XPSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMSVQ1.LT.AMCHK1) THEN
+ XPSQW =
+ & AMCHK1/(XTVD(IXVTA)*ECM**2)
+ DXPSQ = XPSQW-XPSQ(JJ)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
+ & THEN
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)-DXPSQ
+ XPSQ(JJ) = XPSQW
+ ENDIF
+ ENDIF
+* aq-q chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMSVQ2.LT.AMCHK2) THEN
+ XPSQW =
+ & AMCHK2/(XTVQ(IXVTA)*ECM**2)
+ DXPSQ = XPSQW-XPSAQ(JJ)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
+ & THEN
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)-DXPSQ
+ XPSAQ(JJ) = XPSQW
+ ENDIF
+ ENDIF
+*>>>>>>>>>>>end of chain mass correction
+ 4202 CONTINUE
+
+* (b) assign new v-s chains
+* ~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (LSEADI.AND.(
+ & DT_RNDM(AMSVQ2).GT.FRCDIQ))
+ & THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IXVPR,J,1,
+ & IREJ1)
+ IF (IREJ1.EQ.0) GOTO 4203
+ ENDIF
+ NVS = NVS+1
+ ISKPCH(6,NVS) = 0
+ INTVS1(NVS) = IXVPR
+ INTVS2(NVS) = J
+*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
+ AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
+* get lower mass cuts
+ IF (ITSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMIS
+ AMCHK2 = AMAS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMIU
+ AMCHK2 = AMAU
+ ENDIF
+* q-aq chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMVSQ1.LT.AMCHK1) THEN
+ XTSQW =
+ & AMCHK1/(XPVQ(IXVPR)*ECM**2)
+ DXTSQ = XTSQW-XTSAQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
+ & THEN
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)-DXTSQ
+ XTSAQ(J) = XTSQW
+ ENDIF
+ ENDIF
+ IF (AMVSQ2.GT.AMCHK2) THEN
+ XTSQTH =
+ & AMCHK2/(XPVD(IXVPR)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+ XTSQXX =
+ & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
+C & DT_SAMSQX(XTSQTH,XTSQ(J))
+C & DT_SAMPEX(XTSQTH,XTSQ(J))
+**
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)+XTSQ(J)-XTSQXX
+ XTSQ(J) = XTSQXX
+ ELSEIF (AMVSQ2.LT.AMCHK2) THEN
+ XTSQW =
+ & AMCHK2/(XPVD(IXVPR)*ECM**2)
+ DXTSQ = XTSQW-XTSQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
+ & THEN
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)-DXTSQ
+ XTSQ(J) = XTSQW
+ ENDIF
+ ENDIF
+*>>>>>>>>>end of chain mass correction
+ 4203 CONTINUE
+* jump out of s-s chain loop
+ GOTO 420
+ ENDIF
+ ENDIF
+ 4201 CONTINUE
+ ENDIF
+*---->end of chain recombination option
+
+* sample sea-diquark pair (projectile)
+ IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
+ CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ ISKPCH(1,NSS) = 99
+ GOTO 410
+ ENDIF
+ ENDIF
+* sample sea-diquark pair (target)
+ IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
+ CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ ISKPCH(1,NSS) = 99
+ GOTO 410
+ ENDIF
+ ENDIF
+*>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
+ SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
+* check for lower mass cuts
+ IF ((SSMA1Q.LT.SSMIMQ).OR.
+ & (SSMA2Q.LT.SSMIMQ)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
+ & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
+* maximum allowed x values for sea quarks
+ XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
+ & 1.2D0*XSSTHR
+ XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
+ & 1.2D0*XSSTHR
+* resampling of x values not possible - skip sea-sea chains
+ IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
+ & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
+* resampling of x for projectile sea quark pair
+ ICOUS = 0
+ 310 CONTINUE
+ ICOUS = ICOUS+1
+ IF (XSSTHR.GT.0.05D0) THEN
+ XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSPMAX)
+ XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSPMAX)
+ ELSE
+ 320 CONTINUE
+ XPSQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XPSQI.LT.XSSTHR).OR.
+ & (XPSQI.GT.XSPMAX)) GOTO 320
+ 330 CONTINUE
+ XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XPSAQI.LT.XSSTHR).OR.
+ & (XPSAQI.GT.XSPMAX)) GOTO 330
+ ENDIF
+* final test of remaining x for projectile diquark
+ XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
+ & +XPSQ(JJ)+XPSAQ(JJ)
+ IF (XPVDCO.LE.XDTHR) THEN
+*!!!
+C IF (ICOUS.LT.5) GOTO 310
+ IF (ICOUS.LT.0.5D0) GOTO 310
+ GOTO 380
+ ENDIF
+* resampling of x for target sea quark pair
+ ICOUS = 0
+ 350 CONTINUE
+ ICOUS = ICOUS+1
+ IF (XSSTHR.GT.0.05D0) THEN
+ XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSTMAX)
+ XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSTMAX)
+ ELSE
+ 360 CONTINUE
+ XTSQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XTSQI.LT.XSSTHR).OR.
+ & (XTSQI.GT.XSTMAX)) GOTO 360
+ 370 CONTINUE
+ XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XTSAQI.LT.XSSTHR).OR.
+ & (XTSAQI.GT.XSTMAX)) GOTO 370
+ ENDIF
+* final test of remaining x for target diquark
+ XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
+ & +XTSQ(J)+XTSAQ(J)
+ IF (XTVDCO.LT.XDTHR) THEN
+ IF (ICOUS.LT.5) GOTO 350
+ GOTO 380
+ ENDIF
+ XPVD(IPVAL) = XPVDCO
+ XTVD(ITVAL) = XTVDCO
+ XPSQ(JJ) = XPSQI
+ XPSAQ(JJ) = XPSAQI
+ XTSQ(J) = XTSQI
+ XTSAQ(J) = XTSAQI
+*>>>>>end of chain mass correction
+ GOTO 410
+ ENDIF
+* come here to discard s-s interaction
+* resampling of x values not allowed or unsuccessful
+ 380 CONTINUE
+ INTLO(I) = .FALSE.
+ ZUOST(J) = .TRUE.
+ ZUOSP(JJ) = .TRUE.
+ NSS = NSS-1
+ ENDIF
+* consider next s-s interaction
+ GOTO 410
+ ENDIF
+ 390 CONTINUE
+ ENDIF
+ 400 CONTINUE
+ ENDIF
+ 410 CONTINUE
+ 420 CONTINUE
+
+* correct x-values of valence quarks for non-matching sea quarks
+ DO 430 I=1,IXPS
+ IF (ZUOSP(I)) THEN
+ IPVAL = ITOVP(IFROSP(I))
+ XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
+ XPSQ(I) = ZERO
+ XPSAQ(I) = ZERO
+ ZUOSP(I) = .FALSE.
+ ENDIF
+ 430 CONTINUE
+ DO 440 I=1,IXTS
+ IF (ZUOST(I)) THEN
+ ITVAL = ITOVT(IFROST(I))
+ XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
+ XTSQ(I) = ZERO
+ XTSAQ(I) = ZERO
+ ZUOST(I) = .FALSE.
+ ENDIF
+ 440 CONTINUE
+ DO 450 I=1,IXPV
+ IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
+ 450 CONTINUE
+ DO 460 I=1,IXTV
+ IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
+ 460 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_SAMSDQ.FOR
+*COPY DT_SAMSDQ
+*
+*===samsdq=============================================================*
+*
+ SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
+
+************************************************************************
+* SAMpling of Sea-DiQuarks *
+* ECM cm-energy of the nucleon-nucleon system *
+* IDX1,2 indices of x-values of the participating *
+* partons (IDX2 is always the sea-q-pair to be *
+* changed to sea-qq-pair) *
+* MODE = 1 valence-q - sea-diq *
+* = 2 sea-diq - valence-q *
+* = 3 sea-q - sea-diq *
+* = 4 sea-diq - sea-q *
+* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
+* This version dated 17.10.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (ZERO=0.0D0)
+
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+
+* x-values of partons (DTUNUC 1.x)
+ COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
+ & XTVQ(MAXVQU),XTVD(MAXVQU),
+ & XPSQ(MAXSQU),XPSAQ(MAXSQU),
+ & XTSQ(MAXSQU),XTSAQ(MAXSQU)
+
+* flavors of partons (DTUNUC 1.x)
+ COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+ & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+ & IPSQ(MAXSQU),IPSQ2(MAXSQU),
+ & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+ & ITSQ(MAXSQU),ITSQ2(MAXSQU),
+ & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+ & KKPROJ(MAXVQU),KKTARG(MAXVQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+ & IXPV,IXPS,IXTV,IXTS,
+ & INTVV1(MAXVQU),INTVV2(MAXVQU),
+ & INTSV1(MAXVQU),INTSV2(MAXVQU),
+ & INTVS1(MAXVQU),INTVS2(MAXVQU),
+ & INTSS1(MAXSQU),INTSS2(MAXSQU),
+ & INTDV1(MAXVQU),INTDV2(MAXVQU),
+ & INTVD1(MAXVQU),INTVD2(MAXVQU),
+ & INTDS1(MAXSQU),INTDS2(MAXSQU),
+ & INTSD1(MAXSQU),INTSD2(MAXSQU)
+
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+ COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+ & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+
+ IREJ = 0
+* threshold-x for valence diquarks
+ XDTHR = CDQ/ECM
+
+ GOTO (1,2,3,4) MODE
+
+*---------------------------------------------------------------------
+* proj. valence partons - targ. sea partons
+* get x-values and flavors for target sea-diquark pair
+
+ 1 CONTINUE
+ IDXVP = IDX1
+ IDXST = IDX2
+
+* index of corr. val-diquark-x in target nucleon
+ IDXVT = ITOVT(IFROST(IDXST))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the target nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXTV = XDTHR+RR1*XXD/SR123
+ XXTSQ = XDTHR+RR2*XXD/SR123
+ XXTSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXTV = XTVD(IDXVT)
+ XXTSQ = XTSQ(IDXST)
+ XXTSAQ = XTSAQ(IDXST)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
+ ITSAQ2(IDXST) = -ITSQ2(IDXST)
+* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
+ AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
+ AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
+ IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XTVD(IDXVT) = XXTV
+ XTSQ(IDXST) = XXTSQ
+ XTSAQ(IDXST) = XXTSAQ
+ NVD = NVD+1
+ INTVD1(NVD) = IDXVP
+ INTVD2(NVD) = IDXST
+ ISKPCH(7,NVD) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. valence partons
+* get x-values and flavors for projectile sea-diquark pair
+
+ 2 CONTINUE
+ IDXSP = IDX2
+ IDXVT = IDX1
+
+* index of corr. val-diquark-x in projectile nucleon
+ IDXVP = ITOVP(IFROSP(IDXSP))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the projectile nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXPV = XDTHR+RR1*XXD/SR123
+ XXPSQ = XDTHR+RR2*XXD/SR123
+ XXPSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXPV = XPVD(IDXVP)
+ XXPSQ = XPSQ(IDXSP)
+ XXPSAQ = XPSAQ(IDXSP)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
+ IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
+* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
+ AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
+ AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
+ IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XPVD(IDXVP) = XXPV
+ XPSQ(IDXSP) = XXPSQ
+ XPSAQ(IDXSP) = XXPSAQ
+ NDV = NDV+1
+ INTDV1(NDV) = IDXSP
+ INTDV2(NDV) = IDXVT
+ ISKPCH(5,NDV) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. sea partons
+* get x-values and flavors for target sea-diquark pair
+
+ 3 CONTINUE
+ IDXSP = IDX1
+ IDXST = IDX2
+
+* index of corr. val-diquark-x in target nucleon
+ IDXVT = ITOVT(IFROST(IDXST))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the target nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXTV = XDTHR+RR1*XXD/SR123
+ XXTSQ = XDTHR+RR2*XXD/SR123
+ XXTSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXTV = XTVD(IDXVT)
+ XXTSQ = XTSQ(IDXST)
+ XXTSAQ = XTSAQ(IDXST)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
+ ITSAQ2(IDXST) = -ITSQ2(IDXST)
+* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
+ AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
+ AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
+ IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XTVD(IDXVT) = XXTV
+ XTSQ(IDXST) = XXTSQ
+ XTSAQ(IDXST) = XXTSAQ
+ NSD = NSD+1
+ INTSD1(NSD) = IDXSP
+ INTSD2(NSD) = IDXST
+ ISKPCH(3,NSD) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. sea partons
+* get x-values and flavors for projectile sea-diquark pair
+
+ 4 CONTINUE
+ IDXSP = IDX2
+ IDXST = IDX1
+
+* index of corr. val-diquark-x in projectile nucleon
+ IDXVP = ITOVP(IFROSP(IDXSP))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the projectile nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXPV = XDTHR+RR1*XXD/SR123
+ XXPSQ = XDTHR+RR2*XXD/SR123
+ XXPSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXPV = XPVD(IDXVP)
+ XXPSQ = XPSQ(IDXSP)
+ XXPSAQ = XPSAQ(IDXSP)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
+ IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
+* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
+ AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
+ AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
+ IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XPVD(IDXVP) = XXPV
+ XPSQ(IDXSP) = XXPSQ
+ XPSAQ(IDXSP) = XXPSAQ
+ NDS = NDS+1
+ INTDS1(NDS) = IDXSP
+ INTDS2(NDS) = IDXST
+ ISKPCH(2,NDS) = 0
+ RETURN
+ END
+*$ CREATE DT_DIFEVT.FOR
+*COPY DT_DIFEVT
+*
+*===difevt=============================================================*
+*
+ SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
+ & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
+
+************************************************************************
+* Interface to treatment of diffractive interactions. *
+* (input) IFP1/2 PDG-indizes of projectile partons *
+* (baryon: IFP2 - adiquark) *
+* PP(4) projectile 4-momentum *
+* IFT1/2 PDG-indizes of target partons *
+* (baryon: IFT1 - adiquark) *
+* PT(4) target 4-momentum *
+* (output) JDIFF = 0 no diffraction *
+* = 1/-1 LMSD/LMDD *
+* = 2/-2 HMSD/HMDD *
+* NCSY counter for two-chain systems *
+* dumped to DTEVT1 *
+* This version dated 14.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
+ & OHALF=0.5D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+ DIMENSION PP(4),PT(4)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+ IREJ = 0
+ JDIFF = 0
+ IFLAGD = JDIFF
+
+* cm. energy
+ XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
+ & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
+* identities of projectile hadron / target nucleon
+ KPROJ = IDT_ICIHAD(IDHKK(MOP))
+ KTARG = IDT_ICIHAD(IDHKK(MOT))
+
+* single diffractive xsections
+ CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
+* double diffractive xsections
+**!! no double diff yet
+C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
+ DDTOT = 0.0D0
+ DDHM = 0.0D0
+**!!
+* total inelastic xsection
+C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
+ DUMZER = ZERO
+ CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
+ SIGIN = MAX(SIGTO-SIGEL,ZERO)
+
+* fraction of diffractive processes
+ FRADIF = (SDTOT+DDTOT)/SIGIN
+
+ IF (LFIRST) THEN
+ WRITE(LOUT,1000) XM,SDTOT,SIGIN
+ 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
+ & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
+ & F5.1,' mb',/)
+ LFIRST = .FALSE.
+ ENDIF
+
+ IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
+ & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
+* diffractive interaction requested by x-section or by user
+ FRASD = SDTOT/(SDTOT+DDTOT)
+ FRASDH = SDHM/SDTOT
+**sr needs to be specified!!
+C FRADDH = DDHM/DDTOT
+ FRADDH = 1.0D0
+**
+ IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
+* single diffraction
+ KDIFF = 1
+ IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
+ KP = 2
+ KT = 0
+ IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
+ & ISINGD.NE.3) THEN
+ KP = 0
+ KT = 2
+ ENDIF
+ ELSE
+ KP = 1
+ KT = 0
+ IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
+ & ISINGD.NE.3) THEN
+ KP = 0
+ KT = 1
+ ENDIF
+ ENDIF
+ ELSE
+* double diffraction
+ KDIFF = -1
+ IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
+ KP = 2
+ KT = 2
+ ELSE
+ KP = 1
+ KT = 1
+ ENDIF
+ ENDIF
+ CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
+ & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ IFLAGD = 2*KDIFF
+ IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
+ ELSE
+ GOTO 9999
+ ENDIF
+ ENDIF
+ JDIFF = IFLAGD
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DIFFKI.FOR
+*COPY DT_DIFFKI
+*
+*===difkin=============================================================*
+*
+ SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
+ & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
+
+************************************************************************
+* Kinematics of diffractive nucleon-nucleon interaction. *
+* IFP1/2 PDG-indizes of projectile partons *
+* (baryon: IFP2 - adiquark) *
+* PP(4) projectile 4-momentum *
+* IFT1/2 PDG-indizes of target partons *
+* (baryon: IFT1 - adiquark) *
+* PT(4) target 4-momentum *
+* KP = 0 projectile quasi-elastically scattered *
+* = 1 excited to low-mass diff. state *
+* = 2 excited to high-mass diff. state *
+* KT = 0 target quasi-elastically scattered *
+* = 1 excited to low-mass diff. state *
+* = 2 excited to high-mass diff. state *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
+
+ LOGICAL LSTART
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
+ & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
+
+ DATA LSTART /.TRUE./
+
+ IF (LSTART) THEN
+ WRITE(LOUT,2000)
+ 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
+ LSTART = .FALSE.
+ ENDIF
+
+ IREJ = 0
+
+* initialize common /DTDIKI/
+ CALL DT_DIFINI
+* store momenta of initial incoming particles for emc-check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
+ ENDIF
+
+* masses of initial particles
+ XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
+ XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
+ IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
+ XMP = SQRT(XMP2)
+ XMT = SQRT(XMT2)
+* check quark-input (used to adjust coherence cond. for M-selection)
+ IBP = 0
+ IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
+ IBT = 0
+ IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
+
+* parameter for Lorentz-transformation into nucleon-nucleon cms
+ DO 3 K=1,4
+ PITOT(K) = PP(K)+PT(K)
+ 3 CONTINUE
+ XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
+ IF (XMTOT2.LE.ZERO) THEN
+ WRITE(LOUT,1000) XMTOT2
+ 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
+ & 'XMTOT2 = ',E12.3)
+ GOTO 9999
+ ENDIF
+ XMTOT = SQRT(XMTOT2)
+ DO 4 K=1,4
+ BGTOT(K) = PITOT(K)/XMTOT
+ 4 CONTINUE
+* transformation of nucleons into cms
+ CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
+ & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
+ CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
+ & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
+* rotation angles
+ COD = PP1(3)/PPTOT
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(PP1(1)**2+PP1(2)**2)
+ SID = PPT/PPTOT
+ COF = ONE
+ SIF = ZERO
+ IF(PPTOT*SID.GT.TINY10) THEN
+ COF = PP1(1)/(SID*PPTOT)
+ SIF = PP1(2)/(SID*PPTOT)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+* check consistency
+ DO 5 K=1,4
+ DEV1(K) = ABS(PP1(K)+PT1(K))
+ 5 CONTINUE
+ DEV1(4) = ABS(DEV1(4)-XMTOT)
+ IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
+ & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
+ WRITE(LOUT,1001) DEV1
+ 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
+ & /,8X,4E12.3)
+ GOTO 9999
+ ENDIF
+
+* select x-fractions in high-mass diff. interactions
+ IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
+
+* select diffractive masses
+* - projectile
+ IF (KP.EQ.1) THEN
+ XMPF = DT_XMLMD(XMTOT)
+ CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ ELSEIF (KP.EQ.2) THEN
+ XMPF = DT_XMHMD(XMTOT,IBP,1)
+ ELSE
+ XMPF = XMP
+ ENDIF
+* - target
+ IF (KT.EQ.1) THEN
+ XMTF = DT_XMLMD(XMTOT)
+ CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ ELSEIF (KT.EQ.2) THEN
+ XMTF = DT_XMHMD(XMTOT,IBT,2)
+ ELSE
+ XMTF = XMT
+ ENDIF
+
+* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
+ XMPF2 = XMPF**2
+ XMTF2 = XMTF**2
+ PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
+ PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
+
+* select momentum transfer (all t-values used here are <0)
+* minimum absolute value to produce diffractive masses
+ TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
+ TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+
+* longitudinal momentum of excited/elastically scattered projectile
+ PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
+* total transverse momentum due to t-selection
+ PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
+ IF (PPBLT2.LT.ZERO) THEN
+ WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
+ 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
+ & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
+ GOTO 9999
+ ENDIF
+ CALL DT_DSFECF(SINPHI,COSPHI)
+ PPBLT = SQRT(PPBLT2)
+ PPBLOB(1) = COSPHI*PPBLT
+ PPBLOB(2) = SINPHI*PPBLT
+
+* rotate excited/elastically scattered projectile into n-n cms.
+ CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ PPBLOB(1) = XX
+ PPBLOB(2) = YY
+ PPBLOB(3) = ZZ
+
+* 4-momentum of excited/elastically scattered target and of exchanged
+* Pomeron
+ DO 6 K=1,4
+ IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
+ PPOM1(K) = PP1(K)-PPBLOB(K)
+ 6 CONTINUE
+ PTBLOB(4) = XMTOT-PPBLOB(4)
+
+* Lorentz-transformation back into system of initial diff. collision
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
+ & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
+ & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
+ & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
+
+* store 4-momentum of elastically scattered particle (in single diff.
+* events)
+ IF (KP.EQ.0) THEN
+ DO 7 K=1,4
+ PSC(K) = PPF(K)
+ 7 CONTINUE
+ ELSEIF (KT.EQ.0) THEN
+ DO 8 K=1,4
+ PSC(K) = PTF(K)
+ 8 CONTINUE
+ ENDIF
+
+* check consistency of kinematical treatment so far
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ DO 9 K=1,4
+ DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
+ DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
+ 9 CONTINUE
+ IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
+ & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
+ & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
+ & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
+ WRITE(LOUT,1003) DEV1,DEV2
+ 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
+ & 2(/,8X,4E12.3))
+ GOTO 9999
+ ENDIF
+
+* kinematical treatment for low-mass diffraction
+ CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+* dump diffractive chains into DTEVT1
+ CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+ RETURN
+
+ 9999 CONTINUE
+ IRDIFF(1) = IRDIFF(1)+1
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_XMHMD.FOR
+*COPY DT_XMHMD
+*
+*===xmhmd==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
+
+************************************************************************
+* Diffractive mass in high mass single/double diffractive events. *
+* This version dated 11.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+C DATA XCOLOW /0.05D0/
+ DATA XCOLOW /0.15D0/
+
+ DT_XMHMD = ZERO
+ XH = XPH(2)
+ IF (MODE.EQ.2) XH = XTH(2)
+
+* minimum Pomeron-x for high-mass diffraction
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(XH)
+ XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
+ IF (ECM.LE.300.0D0) THEN
+ RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
+ XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
+ ENDIF
+* maximum Pomeron-x for high-mass diffraction
+* (coherence condition, adjusted to fit to experimental data)
+ IF (IB.NE.0) THEN
+* baryon-diffraction
+ XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
+ ELSE
+* meson-diffraction
+ XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
+ ENDIF
+* check boundaries
+ IF (XDIMIN.GE.XDIMAX) THEN
+ XDIMIN = OHALF*XDIMAX
+ ENDIF
+
+ KLOOP = 0
+ 1 CONTINUE
+ KLOOP = KLOOP+1
+ IF (KLOOP.GT.20) RETURN
+* sample Pomeron-x from 1/x-distribution (critical Pomeron)
+ XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
+* corr. diffr. mass
+ DT_XMHMD = ECM*SQRT(XDIFF)
+ IF (DT_XMHMD.LT.2.5D0) GOTO 1
+
+ RETURN
+ END
+
+*$ CREATE DT_XMLMD.FOR
+*COPY DT_XMLMD
+*
+*===xmlmd==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
+
+************************************************************************
+* Diffractive mass in high mass single/double diffractive events. *
+* This version dated 11.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* minimum Pomeron-x for low-mass diffraction
+C AMO = 1.5D0
+ AMO = 2.0D0
+* maximum Pomeron-x for low-mass diffraction
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(AMO)
+ SAM = 1.0D0
+ IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
+ R = DT_RNDM(AMO)*SAM
+ AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
+ AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
+
+* selection of diffractive mass
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(AMU)
+ IF (ECM.LE.50.0D0) THEN
+ DT_XMLMD = AMO*(AMU/AMO)**R
+ ELSE
+ A = 0.7D0
+ IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
+ DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_TDIFF.FOR
+*COPY DT_TDIFF
+*
+*===tdiff==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
+
+************************************************************************
+* t-selection for single/double diffractive interactions. *
+* ECM cm. energy *
+* TMIN minimum momentum transfer to produce diff. masses *
+* XM1/XM2 diffractively produced masses *
+* (for single diffraction XM2 is obsolete) *
+* K1/K2= 0 not excited *
+* = 1 low-mass excitation *
+* = 2 high-mass excitation *
+* This version dated 11.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0)
+
+ PARAMETER ( BTP0 = 3.7D0,
+ & ALPHAP = 0.24D0 )
+
+ IREJ = 0
+ NCLOOP = 0
+ DT_TDIFF = ZERO
+
+ IF (K1.GT.0) THEN
+ XM1 = XM1I
+ XM2 = XM2I
+ ELSE
+ XM1 = XM2I
+ ENDIF
+ XDI = (XM1/ECM)**2
+ IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
+* slope for single diffraction
+ SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
+ ELSE
+* slope for double diffraction
+ SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
+ ENDIF
+
+ 1 CONTINUE
+ NCLOOP = NCLOOP+1
+ IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
+ Y = DT_RNDM(XDI)
+ T = -LOG(1.0D0-Y)/SLOPE
+ IF (ABS(T).LE.ABS(TMIN)) GOTO 1
+ DT_TDIFF = -ABS(T)
+
+ RETURN
+
+ 9999 CONTINUE
+ WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
+ 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
+ & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
+ & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_XVALHM.FOR
+*COPY DT_XVALHM
+*
+*===xvalhm=============================================================*
+*
+ SUBROUTINE DT_XVALHM(KP,KT)
+
+************************************************************************
+* Sampling of parton x-values in high-mass diffractive interactions. *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+ DATA UNON,XVQTHR /2.0D0,0.8D0/
+
+ IF (KP.EQ.2) THEN
+* x-fractions of projectile valence partons
+ 1 CONTINUE
+ XPH(1) = DT_DBETAR(OHALF,UNON)
+ IF (XPH(1).GE.XVQTHR) GOTO 1
+ XPH(2) = ONE-XPH(1)
+* x-fractions of Pomeron q-aq-pair
+ XPOLO = TINY2
+ XPOHI = ONE-TINY2
+ XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
+ XPPO(2) = ONE-XPPO(1)
+* flavors of Pomeron q-aq-pair
+ IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
+ IFPPO(1) = IFLAV
+ IFPPO(2) = -IFLAV
+ IF (DT_RNDM(UNON).GT.OHALF) THEN
+ IFPPO(1) = -IFLAV
+ IFPPO(2) = IFLAV
+ ENDIF
+ ENDIF
+
+ IF (KT.EQ.2) THEN
+* x-fractions of projectile target partons
+ 2 CONTINUE
+ XTH(1) = DT_DBETAR(OHALF,UNON)
+ IF (XTH(1).GE.XVQTHR) GOTO 2
+ XTH(2) = ONE-XTH(1)
+* x-fractions of Pomeron q-aq-pair
+ XPOLO = TINY2
+ XPOHI = ONE-TINY2
+ XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
+ XTPO(2) = ONE-XTPO(1)
+* flavors of Pomeron q-aq-pair
+ IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
+ IFTPO(1) = IFLAV
+ IFTPO(2) = -IFLAV
+ IF (DT_RNDM(XPOLO).GT.OHALF) THEN
+ IFTPO(1) = -IFLAV
+ IFTPO(2) = IFLAV
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_LM2RES.FOR
+*COPY DT_LM2RES
+*
+*===lm2res=============================================================*
+*
+ SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
+
+************************************************************************
+* Check low-mass diffractive excitation for resonance mass. *
+* (input) IF1/2 PDG-indizes of valence partons *
+* (in/out) XM diffractive mass requested/corrected *
+* (output) IDR/IDXR id./BAMJET-index of resonance *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ IREJ = 0
+ IF1B = 0
+ IF2B = 0
+ XMI = XM
+
+* BAMJET indices of partons
+ IF1A = IDT_IPDG2B(IF1,1,2)
+ IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
+ IF2A = IDT_IPDG2B(IF2,1,2)
+ IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
+
+* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
+ IDCH = 2
+ IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
+
+* check for resonance mass
+ CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+ XM = XMN
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_LMKINE.FOR
+*COPY DT_LMKINE
+*
+*===lmkine=============================================================*
+*
+ SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
+
+************************************************************************
+* Kinematical treatment of low-mass excitations. *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DIMENSION P1(4),P2(4)
+
+ IREJ = 0
+
+ IF (KP.EQ.1) THEN
+ PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
+ POE = PPF(4)/PABS
+ FAC1 = OHALF*(POE+ONE)
+ FAC2 = -OHALF*(POE-ONE)
+ DO 1 K=1,3
+ PPLM1(K) = FAC1*PPF(K)
+ PPLM2(K) = FAC2*PPF(K)
+ 1 CONTINUE
+ PPLM1(4) = FAC1*PABS
+ PPLM2(4) = -FAC2*PABS
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFP1)
+ XM2 = PYMASS(IFP2)
+
+ CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 2 K=1,4
+ PPLM1(K) = P1(K)
+ PPLM2(K) = P2(K)
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+
+ IF (KT.EQ.1) THEN
+ PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
+ POE = PTF(4)/PABS
+ FAC1 = OHALF*(POE+ONE)
+ FAC2 = -OHALF*(POE-ONE)
+ DO 3 K=1,3
+ PTLM2(K) = FAC1*PTF(K)
+ PTLM1(K) = FAC2*PTF(K)
+ 3 CONTINUE
+ PTLM2(4) = FAC1*PABS
+ PTLM1(4) = -FAC2*PABS
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFT1)
+ XM2 = PYMASS(IFT2)
+
+ CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 K=1,4
+ PTLM1(K) = P1(K)
+ PTLM2(K) = P2(K)
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DIFINI.FOR
+*COPY DT_DIFINI
+*
+*===difini=============================================================*
+*
+ SUBROUTINE DT_DIFINI
+
+************************************************************************
+* Initialization of common /DTDIKI/ *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DO 1 K=1,4
+ PPOM(K) = ZERO
+ PSC(K) = ZERO
+ PPF(K) = ZERO
+ PTF(K) = ZERO
+ PPLM1(K) = ZERO
+ PPLM2(K) = ZERO
+ PTLM1(K) = ZERO
+ PTLM2(K) = ZERO
+ 1 CONTINUE
+ DO 2 K=1,2
+ XPH(K) = ZERO
+ XPPO(K) = ZERO
+ XTH(K) = ZERO
+ XTPO(K) = ZERO
+ IFPPO(K) = 0
+ IFTPO(K) = 0
+ 2 CONTINUE
+ IDPR = 0
+ IDXPR = 0
+ IDTR = 0
+ IDXTR = 0
+
+ RETURN
+ END
+
+*$ CREATE DT_DIFPUT.FOR
+*COPY DT_DIFPUT
+*
+*===difput=============================================================*
+*
+ SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
+ & IREJ)
+
+************************************************************************
+* Dump diffractive chains into DTEVT1 *
+* This version dated 12.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
+
+ LOGICAL LCHK
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
+ & P1(4),P2(4),P3(4),P4(4)
+
+ IREJ = 0
+
+ IF (KP.EQ.1) THEN
+ DO 1 K=1,4
+ PCH(K) = PPLM1(K)+PPLM2(K)
+ 1 CONTINUE
+ ID1 = IFP1
+ ID2 = IFP2
+ IF (DT_RNDM(PT).GT.OHALF) THEN
+ ID1 = IFP2
+ ID2 = IFP1
+ ENDIF
+ CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
+ & PPLM1(4),0,0,0)
+ CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
+ & PPLM2(4),0,0,0)
+ CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
+ & IDPR,IDXPR,8)
+ ELSEIF (KP.EQ.2) THEN
+ DO 2 K=1,4
+ PP1(K) = XPH(1)*PP(K)
+ PP2(K) = XPH(2)*PP(K)
+ PT1(K) = -XPPO(1)*PPOM(K)
+ PT2(K) = -XPPO(2)*PPOM(K)
+ 2 CONTINUE
+ CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
+ XM1 = ZERO
+ XM2 = ZERO
+ IF (LCHK) THEN
+ CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 3 K=1,4
+ PP1(K) = P1(K)
+ PT1(K) = P2(K)
+ PP2(K) = P3(K)
+ PT2(K) = P4(K)
+ 3 CONTINUE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
+ & PT1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
+ & PT2(4),0,0,8)
+ ELSE
+ CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 K=1,4
+ PP1(K) = P1(K)
+ PT2(K) = P2(K)
+ PP2(K) = P3(K)
+ PT1(K) = P4(K)
+ 4 CONTINUE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
+ & PT2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
+ & PT1(4),0,0,8)
+ ENDIF
+ NCSY = NCSY+1
+ ELSE
+ CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
+ & 0,0,0)
+ ENDIF
+
+ IF (KT.EQ.1) THEN
+ DO 5 K=1,4
+ PCH(K) = PTLM1(K)+PTLM2(K)
+ 5 CONTINUE
+ ID1 = IFT1
+ ID2 = IFT2
+ IF (DT_RNDM(PT).GT.OHALF) THEN
+ ID1 = IFT2
+ ID2 = IFT1
+ ENDIF
+ CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
+ & PTLM1(4),0,0,0)
+ CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
+ & PTLM2(4),0,0,0)
+ CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
+ & IDTR,IDXTR,8)
+ ELSEIF (KT.EQ.2) THEN
+ DO 6 K=1,4
+ PP1(K) = XTPO(1)*PPOM(K)
+ PP2(K) = XTPO(2)*PPOM(K)
+ PT1(K) = XTH(2)*PT(K)
+ PT2(K) = XTH(1)*PT(K)
+ 6 CONTINUE
+ CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
+ XM1 = ZERO
+ XM2 = ZERO
+ IF (LCHK) THEN
+ CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 7 K=1,4
+ PP1(K) = P1(K)
+ PT1(K) = P2(K)
+ PP2(K) = P3(K)
+ PT2(K) = P4(K)
+ 7 CONTINUE
+ CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
+ & PP1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
+ & PP2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,8)
+ ELSE
+ CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 8 K=1,4
+ PP1(K) = P1(K)
+ PT2(K) = P2(K)
+ PP2(K) = P3(K)
+ PT1(K) = P4(K)
+ 8 CONTINUE
+ CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
+ & PP1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
+ & PP2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,8)
+ ENDIF
+ NCSY = NCSY+1
+ ELSE
+ CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
+ & 0,0,0)
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IRDIFF(2) = IRDIFF(2)+1
+ IREJ = 1
+ RETURN
+ END
+*$ CREATE DT_EVTFRG.FOR
+*COPY DT_EVTFRG
+*
+*===evtfrg=============================================================*
+*
+ SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
+
+************************************************************************
+* Hadronization of chains in DTEVT1. *
+* *
+* Input: *
+* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
+* = 2 hadronization of DTUNUC-chains (id=88xxx) *
+* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
+* hadronized with one PYEXEC call *
+* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
+* with one PYEXEC call *
+* Output: *
+* NPYMEM number of entries in JETSET-common after hadronization *
+* IREJ rejection flag *
+* *
+* This version dated 17.09.00 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
+ PARAMETER (ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LACCEP
+
+ PARAMETER (MXJOIN=200)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* phojet
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+* jetset
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+ INTEGER PYK
+
+ DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
+
+ MODE = KMODE
+ ISTSTG = 7
+ IF (MODE.NE.1) ISTSTG = 8
+ IREJ = 0
+
+ IP = 0
+ ISH = 0
+ INIEMC = 1
+ NEND = NHKK
+ NACCEP = 0
+ IFRG = 0
+ IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
+ DO 10 I=NPOINT(3),NEND
+* sr 14.02.00: seems to be not necessary anymore, commented
+C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
+C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
+ LACCEP = .TRUE.
+* pick up chains from dtevt1
+ IDCHK = IDHKK(I)/10000
+ IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
+ IF (IDCHK.EQ.7) THEN
+ IPJE = IDHKK(I)-IDCHK*10000
+ IF (IPJE.NE.IFRG) THEN
+ IFRG = IPJE
+ IF (IFRG.GT.NFRG) GOTO 16
+ ENDIF
+ ELSE
+ IPJE = 1
+ IFRG = IFRG+1
+ IF (IFRG.GT.NFRG) THEN
+ NFRG = -1
+ GOTO 16
+ ENDIF
+ ENDIF
+* statistics counter
+c IF (IDCH(I).LE.8)
+c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
+c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
+* special treatment for small chains already corrected to hadrons
+ IF (IDRES(I).NE.0) THEN
+ IF (IDRES(I).EQ.11) THEN
+ ID = IDXRES(I)
+ ELSE
+ ID = IDT_IPDGHA(IDXRES(I))
+ ENDIF
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),INIEMC,IDUM,IDUM)
+ INIEMC = 2
+ ENDIF
+ IP = IP+1
+ IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
+ P(IP,1) = PHKK(1,I)
+ P(IP,2) = PHKK(2,I)
+ P(IP,3) = PHKK(3,I)
+ P(IP,4) = PHKK(4,I)
+ P(IP,5) = PHKK(5,I)
+ K(IP,1) = 1
+ K(IP,2) = ID
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IHIST(2,I) = 10000*IPJE+IP
+ IF (IHIST(1,I).LE.-100) THEN
+ ISH = ISH+1
+ IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
+ ISJOIN(ISH) = I
+ ENDIF
+ N = IP
+ IHISMO(IP) = I
+ ELSE
+ IJ = 0
+ DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
+ & PHKK(4,KK),INIEMC,IDUM,IDUM)
+ CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
+ INIEMC = 2
+ ENDIF
+ ID = IDHKK(KK)
+ IF (ID.EQ.0) ID = 21
+c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
+c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
+
+c AMRQ = PYMASS(ID)
+
+c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
+c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
+c & (ABS(IDIFF).EQ.0)) THEN
+cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
+c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
+c PHKK(4,KK) = PHKK(4,KK)+DELTA
+c PTOT1 = PTOT-DELTA
+c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
+c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
+c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
+c PHKK(5,KK) = AMRQ
+c ENDIF
+ IP = IP+1
+ IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
+ P(IP,1) = PHKK(1,KK)
+ P(IP,2) = PHKK(2,KK)
+ P(IP,3) = PHKK(3,KK)
+ P(IP,4) = PHKK(4,KK)
+ P(IP,5) = PHKK(5,KK)
+ K(IP,1) = 1
+ K(IP,2) = ID
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IHIST(2,KK) = 10000*IPJE+IP
+ IF (IHIST(1,KK).LE.-100) THEN
+ ISH = ISH+1
+ IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
+ ISJOIN(ISH) = KK
+ ENDIF
+ IJ = IJ+1
+ IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
+ IJOIN(IJ) = IP
+ IHISMO(IP) = I
+ 11 CONTINUE
+ N = IP
+* join the two-parton system
+
+ CALL PYJOIN(IJ,IJOIN)
+
+ ENDIF
+ IDHKK(I) = 99999
+ ENDIF
+ 10 CONTINUE
+ 16 CONTINUE
+ N = IP
+
+ IF (IP.GT.0) THEN
+
+* final state parton shower
+ DO 136 NPJE=1,IPJE
+ IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
+ IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
+ DO 130 K1=1,ISH
+ IF (ISJOIN(K1).EQ.0) GOTO 130
+ I = ISJOIN(K1)
+ IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
+ & GOTO 130
+ IH1 = IHIST(2,I)/10000
+ IF (IH1.NE.NPJE) GOTO 130
+ IH1 = IHIST(2,I)-IH1*10000
+ DO 135 K2=K1+1,ISH
+ IF (ISJOIN(K2).EQ.0) GOTO 135
+ II = ISJOIN(K2)
+ IH2 = IHIST(2,II)/10000
+ IF (IH2.NE.NPJE) GOTO 135
+ IH2 = IHIST(2,II)-IH2*10000
+ IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
+ PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
+ PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
+
+ RQLUN = MIN(PT1,PT2)
+ CALL PYSHOW(IH1,IH2,RQLUN)
+
+ ISJOIN(K1) = 0
+ ISJOIN(K2) = 0
+ GOTO 130
+ ENDIF
+ 135 CONTINUE
+ 130 CONTINUE
+ ENDIF
+ ENDIF
+ 136 CONTINUE
+
+ CALL DT_INITJS(MODE)
+* hadronization
+
+ CALL PYEXEC
+
+ IF (MSTU(24).NE.0) THEN
+ WRITE(LOUT,*) ' JETSET-reject at event',
+ & NEVHKK,MSTU(24),KMODE
+C CALL DT_EVTOUT(4)
+
+C CALL PYLIST(2)
+
+ GOTO 9999
+ ENDIF
+
+* number of entries in LUJETS
+
+ NLINES = PYK(0,1)
+
+ NPYMEM = NLINES
+
+ DO 12 I=1,NLINES
+ IFLG(I) = 0
+ 12 CONTINUE
+
+ DO 13 II=1,NLINES
+
+ IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
+
+* pick up mother resonance if possible and put it together with
+* their decay-products into the common
+ IDXMOR = K(II,3)
+ IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
+ KFMOR = K(IDXMOR,2)
+ ISMOR = K(IDXMOR,1)
+ ELSE
+ KFMOR = 91
+ ISMOR = 1
+ ENDIF
+ IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
+ & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
+ ID = K(IDXMOR,2)
+ MO = IHISMO(PYK(IDXMOR,15))
+ PX = PYP(IDXMOR,1)
+ PY = PYP(IDXMOR,2)
+ PZ = PYP(IDXMOR,3)
+ PE = PYP(IDXMOR,4)
+
+ CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IFLG(IDXMOR) = 1
+ MO = NHKK
+ DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
+ IF (PYK(JDAUG,7).EQ.1) THEN
+ ID = PYK(JDAUG,8)
+ PX = PYP(JDAUG,1)
+ PY = PYP(JDAUG,2)
+ PZ = PYP(JDAUG,3)
+ PE = PYP(JDAUG,4)
+
+ CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IF (LEMCCK) THEN
+ PX = -PYP(JDAUG,1)
+ PY = -PYP(JDAUG,2)
+ PZ = -PYP(JDAUG,3)
+ PE = -PYP(JDAUG,4)
+
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
+ ENDIF
+ IFLG(JDAUG) = 1
+ ENDIF
+ 15 CONTINUE
+ ELSE
+* there was no mother resonance
+ MO = IHISMO(PYK(II,15))
+ ID = PYK(II,8)
+ PX = PYP(II,1)
+ PY = PYP(II,2)
+ PZ = PYP(II,3)
+ PE = PYP(II,4)
+
+ CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IF (LEMCCK) THEN
+ PX = -PYP(II,1)
+ PY = -PYP(II,2)
+ PZ = -PYP(II,3)
+ PE = -PYP(II,4)
+
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
+ ENDIF
+ ENDIF
+ ENDIF
+ 13 CONTINUE
+ IF (LEMCCK) THEN
+ CHKLEV = TINY1
+ CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
+C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
+ ENDIF
+
+* global energy-momentum & flavor conservation check
+**sr 16.5. this check is skipped in case of phojet-treatment
+ IF (MCGENE.EQ.1)
+ & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
+
+* update statistics-counter for diffraction
+c IF (IFLAGD.NE.0) THEN
+c ICDIFF(1) = ICDIFF(1)+1
+c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
+c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
+c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
+c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
+c ENDIF
+
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DECAYS.FOR
+*COPY DT_DECAYS
+*
+*===decay==============================================================*
+*
+ SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
+
+************************************************************************
+* Resonance-decay. *
+* This subroutine replaces DDECAY/DECHKK. *
+* PIN(4) 4-momentum of resonance (input) *
+* IDXIN BAMJET-index of resonance (input) *
+* POUT(20,4) 4-momenta of decay-products (output) *
+* IDXOUT(20) BAMJET-indices of decay-products (output) *
+* NSEC number of secondaries (output) *
+* Adopted from the original version DECHKK. *
+* This version dated 09.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY17=1.0D-17)
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
+ & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
+ & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
+
+* ISTAB = 1 strong and weak decays
+* = 2 strong decays only
+* = 3 strong decays, weak decays for charmed particles and tau
+* leptons only
+ DATA ISTAB /2/
+
+ IREJ = 0
+ NSEC = 0
+* put initial resonance to stack
+ NSTK = 1
+ IDXSTK(NSTK) = IDXIN
+ DO 5 I=1,4
+ PI(NSTK,I) = PIN(I)
+ 5 CONTINUE
+
+* store initial configuration for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
+ & PI(NSTK,4),1,IDUM,IDUM)
+
+ 100 CONTINUE
+* get particle from stack
+ IDXI = IDXSTK(NSTK)
+* skip stable particles
+ IF (ISTAB.EQ.1) THEN
+ IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
+ ELSEIF (ISTAB.EQ.2) THEN
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
+ IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
+ IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
+ IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
+ IF ( IDXI.EQ.109) GOTO 10
+ IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
+ ELSEIF (ISTAB.EQ.3) THEN
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
+ IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
+ IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
+ IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
+ ENDIF
+
+* calculate direction cosines and Lorentz-parameter of decaying part.
+ PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
+ PTOT = MAX(PTOT,TINY17)
+ DO 1 I=1,3
+ DCOS(I) = PI(NSTK,I)/PTOT
+ 1 CONTINUE
+ GAM = PI(NSTK,4)/AAM(IDXI)
+ BGAM = PTOT/AAM(IDXI)
+
+* get decay-channel
+ KCHAN = K1(IDXI)-1
+ 2 CONTINUE
+ KCHAN = KCHAN+1
+ IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
+
+* identities of secondaries
+ IDX(1) = NZK(KCHAN,1)
+ IDX(2) = NZK(KCHAN,2)
+ IF (IDX(2).LT.1) GOTO 9999
+ IDX(3) = NZK(KCHAN,3)
+
+* handle decay in rest system of decaying particle
+ IF (IDX(3).EQ.0) THEN
+* two-particle decay
+ NDEC = 2
+ CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & AAM(IDX(1)),AAM(IDX(2)))
+ ELSE
+* three-particle decay
+ NDEC = 3
+ CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & CODF(3),COFF(3),SIFF(3),
+ & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
+ ENDIF
+ NSTK = NSTK-1
+
+* transform decay products back
+ DO 3 I=1,NDEC
+ NSTK = NSTK+1
+ CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
+ & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
+ & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
+* add particle to stack
+ IDXSTK(NSTK) = IDX(I)
+ DO 4 J=1,3
+ PI(NSTK,J) = DCOSF(J)*PFF(I)
+ 4 CONTINUE
+ 3 CONTINUE
+ GOTO 100
+
+ 10 CONTINUE
+* stable particle, put to output-arrays
+ NSEC = NSEC+1
+ DO 6 I=1,4
+ POUT(NSEC,I) = PI(NSTK,I)
+ 6 CONTINUE
+ IDXOUT(NSEC) = IDXSTK(NSTK)
+* store secondaries for energy-momentum conservation check
+ IF (LEMCCK)
+ &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
+ & -POUT(NSEC,4),2,IDUM,IDUM)
+ NSTK = NSTK-1
+ IF (NSTK.GT.0) GOTO 100
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DECAY1.FOR
+*COPY DT_DECAY1
+*
+*===decay1=============================================================*
+*
+ SUBROUTINE DT_DECAY1
+
+************************************************************************
+* Decay of resonances stored in DTEVT1. *
+* This version dated 20.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
+
+ NEND = NHKK
+C DO 1 I=NPOINT(5),NEND
+ DO 1 I=NPOINT(4),NEND
+ IF (ABS(ISTHKK(I)).EQ.1) THEN
+ DO 2 K=1,4
+ PIN(K) = PHKK(K,I)
+ 2 CONTINUE
+ IDXIN = IDBAM(I)
+ CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
+ IF (NSEC.GT.1) THEN
+ DO 3 N=1,NSEC
+ IDHAD = IDT_IPDGHA(IDXOUT(N))
+ CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
+ & POUT(N,3),POUT(N,4),0,0,0)
+ 3 CONTINUE
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_DECPI0.FOR
+*COPY DT_DECPI0
+*
+*===decpi0=============================================================*
+*
+ SUBROUTINE DT_DECPI0
+
+************************************************************************
+* Decay of pi0 handled with JETSET. *
+* This version dated 18.02.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ INTEGER PYCOMP,PYK
+
+ DIMENSION IHISMO(NMXHKK),P1(4)
+
+ TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
+
+ CALL DT_INITJS(2)
+* allow pi0 decay
+
+ KC = PYCOMP(111)
+
+ MDCY(KC,1) = 1
+
+ NN = 0
+ INI = 0
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
+ IF (INI.EQ.0) THEN
+ INI = 1
+ ELSE
+ INI = 2
+ ENDIF
+ IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),INI,IDUM,IDUM)
+ PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
+ PTOT = SQRT(PT**2+PHKK(3,I)**2)
+ COSTH = PHKK(3,I)/(PTOT+TINY10)
+ IF (COSTH.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTH.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTH)
+ ENDIF
+ PHI = ASIN(PHKK(2,I)/(PT +TINY10))
+ IF (PHKK(1,I).LT.0.0D0)
+
+ & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
+
+ ENER = PHKK(4,I)
+ NN = NN+1
+ KTEMP = MSTU(10)
+ MSTU(10)= 1
+ P(NN,5) = PHKK(5,I)
+
+ CALL PY1ENT(NN,111,ENER,THETA,PHI)
+
+ MSTU(10) = KTEMP
+ IHISMO(NN)= I
+ ENDIF
+ 1 CONTINUE
+ IF (NN.GT.0) THEN
+
+ CALL PYEXEC
+
+ NLINES = PYK(0,1)
+
+ DO 2 II=1,NLINES
+
+ IF (PYK(II,7).EQ.1) THEN
+
+ DO 3 KK=1,4
+
+ P1(KK) = PYP(II,KK)
+
+ 3 CONTINUE
+
+ ID = PYK(II,8)
+ MO = IHISMO(PYK(II,15))
+
+ CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
+ & IDUM,IDUM)
+*sr: flag with neg. sign (for HELIOS p/A-W jobs)
+ ISTHKK(MO) = -2
+ ENDIF
+ 2 CONTINUE
+ IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
+ ENDIF
+ MDCY(KC,1) = 0
+
+ RETURN
+ END
+
+*$ CREATE DT_DTWOPD.FOR
+*COPY DT_DTWOPD
+*
+*===dtwopd=============================================================*
+*
+ SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
+ & COF2,SIF2,AM1,AM2)
+
+************************************************************************
+* Two-particle decay. *
+* UMO cm-energy of the decaying system (input) *
+* AM1/AM2 masses of the decay products (input) *
+* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
+* COD,COF,SIF direction cosines of the decay prod. (output) *
+* Revised by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
+
+ IF (UMO.LT.(AM1+AM2)) THEN
+ WRITE(LOUT,1000) UMO,AM1,AM2
+ 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
+ & 3E12.3)
+ STOP
+ ENDIF
+
+ ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
+ ECM2 = UMO-ECM1
+ PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
+ PCM2 = PCM1
+ CALL DT_DSFECF(SIF1,COF1)
+ COD1 = TWO*DT_RNDM(PCM2)-ONE
+ COD2 = -COD1
+ COF2 = -COF1
+ SIF2 = -SIF1
+
+ RETURN
+ END
+
+*$ CREATE DT_DTHREP.FOR
+*COPY DT_DTHREP
+*
+*===dthrep=============================================================*
+*
+ SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
+ & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
+
+************************************************************************
+* Three-particle decay. *
+* UMO cm-energy of the decaying system (input) *
+* AM1/2/3 masses of the decay products (input) *
+* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
+* COD,COF,SIF direction cosines of the decay prod. (output) *
+* *
+* Threpd89: slight revision by A. Ferrari *
+* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
+* Revised by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER ( ANGLSQ = 2.5D-31 )
+ PARAMETER ( AZRZRZ = 1.0D-30 )
+ PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
+
+ COMMON /HNGAMR/ REDU,AMO,AMM(15)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ DIMENSION F(5),XX(5)
+ DATA EPS /AZRZRZ/
+
+ UMOO=UMO+UMO
+C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
+C***J. VON NEUMANN - RANDOM - SELECTION OF S2
+C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
+ UUMO=UMO
+ AAM1=AM1
+ AAM2=AM2
+ AAM3=AM3
+ GU=(AM2+AM3)**2
+ GO=(UMO-AM1)**2
+* UFAK=1.0000000000001D0
+* IF (GU.GT.GO) UFAK=0.9999999999999D0
+ IF (GU.GT.GO) THEN
+ UFAK=ONEMNS
+ ELSE
+ UFAK=ONEPLS
+ END IF
+ OFAK=2.D0-UFAK
+ GU=GU*UFAK
+ GO=GO*OFAK
+ DS2=(GO-GU)/99.D0
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ AM33=AM3*AM3
+ UMO2=UMO*UMO
+ RHO2=0.D0
+ S22=GU
+ DO 124 I=1,100
+ S21=S22
+ S22=GU+(I-1.D0)*DS2
+ RHO1=RHO2
+ RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
+ * (S22+EPS)
+ IF(RHO2.LT.RHO1) GO TO 125
+ 124 CONTINUE
+ 125 S2SUP=(S22-S21)*.5D0+S21
+ SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
+ * (S2SUP+EPS)
+ SUPRHO=SUPRHO*1.05D0
+ XO=S21-DS2
+ IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
+ IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
+ XX(1)=XO
+ XX(3)=S22
+ X1=(XO+S22)*0.5D0
+ XX(2)=X1
+ F(3)=RHO2
+ F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
+ F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
+ DO 126 I=1,16
+ X4=(XX(1)+XX(2))*0.5D0
+ X5=(XX(2)+XX(3))*0.5D0
+ F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
+ * (X4+EPS)
+ F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
+ * (X5+EPS)
+ XX(4)=X4
+ XX(5)=X5
+ DO 128 II=1,5
+ IA=II
+ DO 128 III=IA,5
+ IF (F (II).GE.F (III)) GO TO 128
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+128 CONTINUE
+ SUPRHO=F(1)
+ S2SUP=XX(1)
+ DO 129 II=1,3
+ IA=II
+ DO 129 III=IA,3
+ IF (XX(II).GE.XX(III)) GO TO 129
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+129 CONTINUE
+126 CONTINUE
+ AM23=(AM2+AM3)**2
+ ITH=0
+ REDU=2.D0
+ 1 CONTINUE
+ ITH=ITH+1
+ IF (ITH.GT.200) REDU=-9.D0
+ IF (ITH.GT.200) GO TO 400
+ C=DT_RNDM(REDU)
+* S2=AM23+C*((UMO-AM1)**2-AM23)
+ S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
+ Y=DT_RNDM(S2)
+ Y=Y*SUPRHO
+ RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
+ IF(Y.GT.RHO) GO TO 1
+C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
+ S1=DT_RNDM(S2)
+ S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
+ &RHO*.5D0
+ S3=UMO2+AM11+AM22+AM33-S1-S2
+ ECM1=(UMO2+AM11-S2)/UMOO
+ ECM2=(UMO2+AM22-S3)/UMOO
+ ECM3=(UMO2+AM33-S1)/UMOO
+ PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
+ PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
+ PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
+ CALL DT_DSFECF(SFE,CFE)
+C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
+C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
+ PCM12 = PCM1 * PCM2
+ IF ( PCM12 .LT. ANGLSQ ) GO TO 200
+ COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
+ GO TO 300
+ 200 CONTINUE
+ UW=DT_RNDM(S1)
+ COSTH=(UW-0.5D+00)*2.D+00
+ 300 CONTINUE
+* IF(ABS(COSTH).GT.0.9999999999999999D0)
+* &COSTH=SIGN(0.9999999999999999D0,COSTH)
+ IF(ABS(COSTH).GT.ONEONE)
+ &COSTH=SIGN(ONEONE,COSTH)
+ IF (REDU.LT.1.D+00) RETURN
+ COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
+* IF(ABS(COSTH2).GT.0.9999999999999999D0)
+* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
+ IF(ABS(COSTH2).GT.ONEONE)
+ &COSTH2=SIGN(ONEONE,COSTH2)
+ SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
+ SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
+ SINTH1=COSTH2*SINTH-COSTH*SINTH2
+ COSTH1=COSTH*COSTH2+SINTH2*SINTH
+C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
+C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
+C***THE DIRECTION OF PARTICLE 3
+C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
+ CX11=-COSTH1
+ CY11=SINTH1*CFE
+ CZ11=SINTH1*SFE
+ CX22=-COSTH2
+ CY22=-SINTH2*CFE
+ CZ22=-SINTH2*SFE
+ CALL DT_DSFECF(SIF3,COF3)
+ COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
+ SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
+ 2 FORMAT(5F20.15)
+ COD1=CX11*COD3+CZ11*SID3
+ CHLP=(ONEONE-COD1)*(ONEONE+COD1)
+ IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
+ &CX11,CZ11
+ SID1=SQRT(CHLP)
+ COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
+ SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
+ COD2=CX22*COD3+CZ22*SID3
+ SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
+ COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
+ SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
+ 400 CONTINUE
+* === Energy conservation check: === *
+ EOCHCK = UMO - ECM1 - ECM2 - ECM3
+* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
+* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
+* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
+ PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
+ PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
+ & + PCM3 * COF3 * SID3
+ PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
+ & + PCM3 * SIF3 * SID3
+ EOCMPR = 1.D-12 * UMO
+ IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
+ & .GT. EOCMPR ) THEN
+**sr 5.5.95 output-unit changed
+ IF (IOULEV(1).GT.0) THEN
+ WRITE(LOUT,*)
+ & ' *** Threpd: energy/momentum conservation failure! ***',
+ & EOCHCK,PXCHCK,PYCHCK,PZCHCK
+ WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
+ ENDIF
+**
+ END IF
+ RETURN
+ END
+
+*$ CREATE DT_DBKLAS.FOR
+*COPY DT_DBKLAS
+*
+*===dbklas=============================================================*
+*
+ SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* quark-content to particle index conversion (DTUNUC 1.x)
+ COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
+ & IA08(6,21),IA10(6,21)
+
+ IF (I) 20,20,10
+* baryons
+ 10 CONTINUE
+ CALL DT_INDEXD(J,K,IND)
+ I8 = IB08(I,IND)
+ I10 = IB10(I,IND)
+ IF (I8.LE.0) I8 = I10
+ RETURN
+* antibaryons
+ 20 CONTINUE
+ II = IABS(I)
+ JJ = IABS(J)
+ KK = IABS(K)
+ CALL DT_INDEXD(JJ,KK,IND)
+ I8 = IA08(II,IND)
+ I10 = IA10(II,IND)
+ IF (I8.LE.0) I8 = I10
+
+ RETURN
+ END
+
+*$ CREATE DT_INDEXD.FOR
+*COPY DT_INDEXD
+*
+*===indexd=============================================================*
+*
+ SUBROUTINE DT_INDEXD(KA,KB,IND)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ KP = KA*KB
+ KS = KA+KB
+ IF (KP.EQ.1) IND=1
+ IF (KP.EQ.2) IND=2
+ IF (KP.EQ.3) IND=3
+ IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
+ IF (KP.EQ.5) IND=5
+ IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
+ IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
+ IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
+ IF (KP.EQ.8) IND=9
+ IF (KP.EQ.10) IND=10
+ IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
+ IF (KP.EQ.9) IND=12
+ IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
+ IF (KP.EQ.15) IND=14
+ IF (KP.EQ.18) IND=15
+ IF (KP.EQ.16) IND=16
+ IF (KP.EQ.20) IND=17
+ IF (KP.EQ.24) IND=18
+ IF (KP.EQ.25) IND=19
+ IF (KP.EQ.30) IND=20
+ IF (KP.EQ.36) IND=21
+
+ RETURN
+ END
+
+*$ CREATE DT_DCHANT.FOR
+*COPY DT_DCHANT
+*
+*===dchant=============================================================*
+*
+ SUBROUTINE DT_DCHANT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION HWT(IDMAX9)
+
+* change of weights wt from absolut values into the sum of wt of a dec.
+ DO 10 J=1,IDMAX9
+ HWT(J) = ZERO
+ 10 CONTINUE
+C DO 999 KKK=1,210
+C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
+C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
+C & K1(KKK),K2(KKK)
+C 999 CONTINUE
+C STOP
+ DO 30 I=1,210
+ IK1 = K1(I)
+ IK2 = K2(I)
+ HV = ZERO
+ DO 20 J=IK1,IK2
+ HV = HV+WT(J)
+ HWT(J) = HV
+**sr 13.1.95
+ IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
+ 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
+ 20 CONTINUE
+ 30 CONTINUE
+ DO 40 J=1,IDMAX9
+ WT(J) = HWT(J)
+ 40 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_DDATAR.FOR
+*COPY DT_DDATAR
+*
+*===ddatar=============================================================*
+*
+ SUBROUTINE DT_DDATAR
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+* quark-content to particle index conversion (DTUNUC 1.x)
+ COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
+ & IA08(6,21),IA10(6,21)
+
+ DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
+
+ DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
+ & 0, 0, 36, 37, 96,127, 0, 0,126,125,
+ & 128,129,14*0/
+ DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
+ & 0, 0, 15, 24, 31,120, 0, 0,119,118,
+ & 121,122,14*0/
+ DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
+ & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
+ & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
+ & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
+ & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
+ & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
+ & 0, 0, 0,140,137,138,146, 0, 0,142,
+ & 139,147, 0, 0,145,148, 50*0/
+ DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
+ & 0,107,164, 0, 0,167, 0, 0, 0, 0,
+ & 0, 54, 55,105,162, 0, 0, 56,106,163,
+ & 0, 0,108,165, 0, 0,168, 0, 0, 0,
+ & 0, 0,104,105,107,164, 0, 0,106,108,
+ & 165, 0, 0,109,166, 0, 0,169, 0, 0,
+ & 0, 0, 0,161,162,164,167, 0, 0,163,
+ & 165,168, 0, 0,166,169, 0, 0,170,47*0/
+ DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
+ & 0,102,150, 0, 0,158, 0, 0, 0, 0,
+ & 0, 2, 9,100,149, 0, 0, 0,101,154,
+ & 0, 0,103,151, 0, 0,159, 0, 0, 0,
+ & 0, 0, 99,100,102,150, 0, 0,101,103,
+ & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
+ & 0, 0, 0,152,149,150,158, 0, 0,154,
+ & 151,159, 0, 0,157,160, 50*0/
+ DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
+ & 0,113,174, 0, 0,177, 0, 0, 0, 0,
+ & 0, 68, 69,111,172, 0, 0, 70,112,173,
+ & 0, 0,114,175, 0, 0,178, 0, 0, 0,
+ & 0, 0,110,111,113,174, 0, 0,112,114,
+ & 175, 0, 0,115,176, 0, 0,179, 0, 0,
+ & 0, 0, 0,171,172,174,177, 0, 0,173,
+ & 175,178, 0, 0,176,179, 0, 0,180,47*0/
+
+ L=0
+ DO 2 I=1,6
+ DO 1 J=1,6
+ L = L+1
+ IMPS(I,J) = IP(L)
+ IMVE(I,J) = IV(L)
+ 1 CONTINUE
+ 2 CONTINUE
+ L=0
+ DO 4 I=1,6
+ DO 3 J=1,21
+ L = L+1
+ IB08(I,J) = IB(L)
+ IB10(I,J) = IBB(L)
+ IA08(I,J) = IA(L)
+ IA10(I,J) = IAA(L)
+ 3 CONTINUE
+ 4 CONTINUE
+C A1 = 0.88D0
+C B1 = 3.0D0
+C B2 = 3.0D0
+C B3 = 8.0D0
+C LT = 0
+C LB = 0
+C BET = 12.0D0
+C AS = 0.25D0
+C B8 = 0.33D0
+C AME = 0.95D0
+C DIQ = 0.375D0
+C ISU = 4
+
+ RETURN
+ END
+
+*$ CREATE DT_INITJS.FOR
+*COPY DT_INITJS
+*
+*===initjs=============================================================*
+*
+ SUBROUTINE DT_INITJS(MODE)
+
+************************************************************************
+* Initialize JETSET paramters. *
+* MODE = 0 default settings *
+* = 1 PHOJET settings *
+* = 2 DTUNUC settings *
+* This version dated 16.02.96 is written by S. Roesler *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LFIRST,LFIRDT,LFIRPH
+
+* INCLUDE '(DIMPAR)'
+* DIMPAR taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(PART)'
+* PART taken from FLUKA
+ PARAMETER ( KPETA0 = 31 )
+ PARAMETER ( KPRHOP = 32 )
+ PARAMETER ( KPRHO0 = 33 )
+ PARAMETER ( KPRHOM = 34 )
+ PARAMETER ( KPOME0 = 35 )
+ PARAMETER ( KPPHI0 = 96 )
+ PARAMETER ( KPDEPP = 53 )
+ PARAMETER ( KPDELP = 54 )
+ PARAMETER ( KPDEL0 = 55 )
+ PARAMETER ( KPDELM = 56 )
+ PARAMETER ( KPN14P = 91 )
+ PARAMETER ( KPN140 = 92 )
+* Low mass diffraction partners:
+ PARAMETER ( KDETA0 = 0 )
+ PARAMETER ( KDRHOP = 0 )
+ PARAMETER ( KDRHO0 = 210 )
+ PARAMETER ( KDRHOM = 0 )
+ PARAMETER ( KDOME0 = 210 )
+ PARAMETER ( KDPHI0 = 210 )
+ PARAMETER ( KDDEPP = 0 )
+ PARAMETER ( KDDELP = 0 )
+ PARAMETER ( KDDEL0 = 0 )
+ PARAMETER ( KDDELM = 0 )
+ PARAMETER ( KDN14P = 0 )
+ PARAMETER ( KDN140 = 0 )
+*
+ CHARACTER*8 ANAME
+ COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
+ & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
+ & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
+ & ATXN14, ATMN14, RNRN14 (-10:10),
+ & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
+ & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
+ & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
+ & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
+ & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
+ & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ INTEGER PYCOMP
+
+ DIMENSION IDXSTA(40)
+ DATA IDXSTA
+* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
+ & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
+* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
+ & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
+* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
+ & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
+* Ksic0 aKsic+aKsic0 sig0 asig0
+ & 4132,-4232,-4132, 3212,-3212, 5*0/
+
+ DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
+
+ IF (LFIRST) THEN
+* save default settings
+ PDEF1 = PARJ(1)
+ PDEF2 = PARJ(2)
+ PDEF3 = PARJ(3)
+ PDEF5 = PARJ(5)
+ PDEF6 = PARJ(6)
+ PDEF7 = PARJ(7)
+ PDEF18 = PARJ(18)
+ PDEF19 = PARJ(19)
+ PDEF21 = PARJ(21)
+ PDEF42 = PARJ(42)
+ MDEF12 = MSTJ(12)
+* LUJETS / PYJETS array-dimensions
+
+ MSTU(4) = 4000
+
+* increase maximum number of JETSET-error prints
+ MSTU(22) = 50000
+* prevent particles decaying
+ DO 1 I=1,35
+ IF (I.LT.34) THEN
+
+ KC = PYCOMP(IDXSTA(I))
+
+ IF (KC.GT.0) THEN
+ IF (I.EQ.2) THEN
+* pi0 decay
+C MDCY(KC,1) = 1
+ MDCY(KC,1) = 0
+**cr mode
+C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
+C & (I.EQ.8).OR.(I.EQ.10)) THEN
+C ELSEIF (I.EQ.4) THEN
+C MDCY(KC,1) = 1
+**
+ ELSE
+ MDCY(KC,1) = 0
+ ENDIF
+ ENDIF
+ ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
+
+ KC = PYCOMP(IDXSTA(I))
+
+ IF (KC.GT.0) THEN
+ MDCY(KC,1) = 0
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+*
+
+* as Fluka event-generator: allow only paprop particles to be stable
+* and let all other particles decay (i.e. those with strong decays)
+ IF (ITRSPT.EQ.1) THEN
+ DO 5 I=1,IDMAXP
+ IF (KPTOIP(I).NE.0) THEN
+ IDPDG = MPDGHA(I)
+
+ KC = PYCOMP(IDPDG)
+
+ IF (KC.GT.0) THEN
+ IF (MDCY(KC,1).EQ.1) THEN
+ WRITE(LOUT,*)
+ & ' DT_INITJS: Decay flag for FLUKA-',
+ & 'transport : particle should not ',
+ & 'decay : ',IDPDG,' ',ANAME(I)
+ MDCY(KC,1) = 0
+ ENDIF
+ ENDIF
+ ENDIF
+ 5 CONTINUE
+ DO 6 KC=1,500
+ IDPDG = KCHG(KC,4)
+ KP = MCIHAD(IDPDG)
+ IF (KP.GT.0) THEN
+ IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
+ & (ANAME(KP).NE.'BLANK ').AND.
+ & (ANAME(KP).NE.'RNDFLV ')) THEN
+ WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
+ & 'transport: particle should decay ',
+ & ': ',IDPDG,' ',ANAME(KP)
+ MDCY(KC,1) = 1
+ ENDIF
+ ENDIF
+ 6 CONTINUE
+ ENDIF
+
+*
+* popcorn:
+ IF (PDB.LE.ZERO) THEN
+* no popcorn-mechanism
+ MSTJ(12) = 1
+ ELSE
+ MSTJ(12) = 3
+ PARJ(5) = PDB
+ ENDIF
+* set JETSET-parameter requested by input cards
+ IF (NMSTU.GT.0) THEN
+ DO 2 I=1,NMSTU
+ MSTU(IMSTU(I)) = MSTUX(I)
+ 2 CONTINUE
+ ENDIF
+ IF (NMSTJ.GT.0) THEN
+ DO 3 I=1,NMSTJ
+ MSTJ(IMSTJ(I)) = MSTJX(I)
+ 3 CONTINUE
+ ENDIF
+ IF (NPARU.GT.0) THEN
+ DO 4 I=1,NPARU
+ PARU(IPARU(I)) = PARUX(I)
+ 4 CONTINUE
+ ENDIF
+ LFIRST = .FALSE.
+ ENDIF
+*
+* PARJ(1) suppression of qq-aqaq pair prod. compared to
+* q-aq pair prod. (default: 0.1)
+* PARJ(2) strangeness suppression (default: 0.3)
+* PARJ(3) extra suppression of strange diquarks (default: 0.4)
+* PARJ(6) extra suppression of sas-pair shared by B and
+* aB in BMaB (default: 0.5)
+* PARJ(7) extra suppression of strange meson M in BMaB
+* configuration (default: 0.5)
+* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
+* PARJ(21) width sigma in Gaussian p_x, p_y transverse
+* momentum distrib. for prim. hadrons (default: 0.35)
+* PARJ(42) b-parameter for symmetric Lund-fragmentation
+* function (default: 0.9 GeV^-2)
+*
+* PHOJET settings
+ IF (MODE.EQ.1) THEN
+* JETSET default
+C PARJ(1) = PDEF1
+C PARJ(2) = PDEF2
+C PARJ(3) = PDEF3
+C PARJ(6) = PDEF6
+C PARJ(7) = PDEF7
+C PARJ(18) = PDEF18
+C PARJ(21) = PDEF21
+C PARJ(42) = PDEF42
+**sr 18.11.98 parameter tuning
+C PARJ(1) = 0.092D0
+C PARJ(2) = 0.25D0
+C PARJ(3) = 0.45D0
+C PARJ(19) = 0.3D0
+C PARJ(21) = 0.45D0
+C PARJ(42) = 1.0D0
+**sr 28.04.99 parameter tuning (May 99 minor modifications)
+ PARJ(1) = 0.085D0
+ PARJ(2) = 0.26D0
+ PARJ(3) = 0.8D0
+ PARJ(11) = 0.38D0
+ PARJ(18) = 0.3D0
+ PARJ(19) = 0.4D0
+ PARJ(21) = 0.36D0
+ PARJ(41) = 0.3D0
+ PARJ(42) = 0.86D0
+ IF (NPARJ.GT.0) THEN
+ DO 10 I=1,NPARJ
+ IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
+ 10 CONTINUE
+ ENDIF
+ IF (LFIRPH) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'DT_INITJS: JETSET-parameter for PHOJET'
+ CALL DT_JSPARA(0)
+ LFIRPH = .FALSE.
+ ENDIF
+* DTUNUC settings
+ ELSEIF (MODE.EQ.2) THEN
+ IF (IFRAG(2).EQ.1) THEN
+**sr parameters before 9.3.96
+C PARJ(2) = 0.27D0
+C PARJ(3) = 0.6D0
+C PARJ(6) = 0.75D0
+C PARJ(7) = 0.75D0
+C PARJ(21) = 0.55D0
+C PARJ(42) = 1.3D0
+**sr 18.11.98 parameter tuning
+C PARJ(1) = 0.05D0
+C PARJ(2) = 0.27D0
+C PARJ(3) = 0.4D0
+C PARJ(19) = 0.2D0
+C PARJ(21) = 0.45D0
+C PARJ(42) = 1.0D0
+**sr 28.04.99 parameter tuning
+ PARJ(1) = 0.11D0
+ PARJ(2) = 0.36D0
+ PARJ(3) = 0.8D0
+ PARJ(19) = 0.2D0
+ PARJ(21) = 0.3D0
+ PARJ(41) = 0.3D0
+ PARJ(42) = 0.58D0
+ IF (NPARJ.GT.0) THEN
+ DO 20 I=1,NPARJ
+ IF (IPARJ(I).LT.0) THEN
+ IDX = ABS(IPARJ(I))
+ PARJ(IDX) = PARJX(I)
+ ENDIF
+ 20 CONTINUE
+ ENDIF
+ IF (LFIRDT) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'DT_INITJS: JETSET-parameter for DTUNUC'
+ CALL DT_JSPARA(0)
+ LFIRDT = .FALSE.
+ ENDIF
+ ELSEIF (IFRAG(2).EQ.2) THEN
+ PARJ(1) = 0.11D0
+ PARJ(2) = 0.27D0
+ PARJ(3) = 0.3D0
+ PARJ(6) = 0.35D0
+ PARJ(7) = 0.45D0
+ PARJ(18) = 0.66D0
+C PARJ(21) = 0.55D0
+C PARJ(42) = 1.0D0
+ PARJ(21) = 0.60D0
+ PARJ(42) = 1.3D0
+ ELSE
+ PARJ(1) = PDEF1
+ PARJ(2) = PDEF2
+ PARJ(3) = PDEF3
+ PARJ(6) = PDEF6
+ PARJ(7) = PDEF7
+ PARJ(18) = PDEF18
+ PARJ(21) = PDEF21
+ PARJ(42) = PDEF42
+ ENDIF
+ ELSE
+ PARJ(1) = PDEF1
+ PARJ(2) = PDEF2
+ PARJ(3) = PDEF3
+ PARJ(5) = PDEF5
+ PARJ(6) = PDEF6
+ PARJ(7) = PDEF7
+ PARJ(18) = PDEF18
+ PARJ(19) = PDEF19
+ PARJ(21) = PDEF21
+ PARJ(42) = PDEF42
+ MSTJ(12) = MDEF12
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_JSPARA.FOR
+*COPY DT_JSPARA
+*
+*===jspara=============================================================*
+*
+ SUBROUTINE DT_JSPARA(MODE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
+ & ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LFIRST
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
+
+ DATA LFIRST /.TRUE./
+
+* save the default JETSET-parameter on the first call
+ IF (LFIRST) THEN
+ DO 1 I=1,200
+ ISTU(I) = MSTU(I)
+ QARU(I) = PARU(I)
+ ISTJ(I) = MSTJ(I)
+ QARJ(I) = PARJ(I)
+ 1 CONTINUE
+ LFIRST = .FALSE.
+ ENDIF
+
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
+
+* compare the default JETSET-parameter with the present values
+ DO 2 I=1,200
+ IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
+ WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
+C ISTU(I) = MSTU(I)
+ ENDIF
+ DIFF = ABS(PARU(I)-QARU(I))
+ IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
+ WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
+C QARU(I) = PARU(I)
+ ENDIF
+ IF (MSTJ(I).NE.ISTJ(I)) THEN
+ WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
+C ISTJ(I) = MSTJ(I)
+ ENDIF
+ DIFF = ABS(PARJ(I)-QARJ(I))
+ IF (DIFF.GE.1.0D-5) THEN
+ WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
+C QARJ(I) = PARJ(I)
+ ENDIF
+ 2 CONTINUE
+ 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
+ 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
+
+ RETURN
+ END
+*$ CREATE DT_FOZOCA.FOR
+*COPY DT_FOZOCA
+*
+*===fozoca=============================================================*
+*
+ SUBROUTINE DT_FOZOCA(LFZC,IREJ)
+
+************************************************************************
+* This subroutine treats the complete FOrmation ZOne supressed intra- *
+* nuclear CAscade. *
+* LFZC = .true. cascade has been treated *
+* = .false. cascade skipped *
+* This is a completely revised version of the original FOZOKL. *
+* This version dated 18.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
+ PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
+
+ LOGICAL LSTART,LCAS,LFZC
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* final state after intranuclear cascade step
+ COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+ DIMENSION NCWOUN(2)
+
+ DATA LSTART /.TRUE./
+
+ LFZC = .TRUE.
+ IREJ = 0
+
+* skip cascade if hadron-hadron interaction or if supressed by user
+ IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
+* skip cascade if not all possible chains systems are hadronized
+ DO 1 I=1,8
+ IF (.NOT.LHADRO(I)) GOTO 9999
+ 1 CONTINUE
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
+ 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
+ & 'maximum of',I4,' generations',/,10X,'formation time ',
+ & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
+ IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
+ IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
+ 1001 FORMAT(10X,'p_t dependent formation zone',/)
+ 1002 FORMAT(10X,'constant formation zone',/)
+ LSTART = .FALSE.
+ ENDIF
+
+* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
+* which may interact with final state particles are stored in a seperate
+* array - here all proj./target nucleon-indices (just for simplicity)
+ NOINC = 0
+ DO 9 I=1,NPOINT(1)-1
+ NOINC = NOINC+1
+ IDXINC(NOINC) = I
+ 9 CONTINUE
+
+* initialize Pauli-principle treatment (find wounded nucleons)
+ NWOUND(1) = 0
+ NWOUND(2) = 0
+ NCWOUN(1) = 0
+ NCWOUN(2) = 0
+ DO 2 J=1,NPOINT(1)
+ DO 3 I=1,2
+ IF (ISTHKK(J).EQ.10+I) THEN
+ NWOUND(I) = NWOUND(I)+1
+ EWOUND(I,NWOUND(I)) = PHKK(4,J)
+ IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
+ ENDIF
+ 3 CONTINUE
+ 2 CONTINUE
+
+* modify nuclear potential for wounded nucleons
+ IPRCL = IP -NWOUND(1)
+ IPZRCL = IPZ-NCWOUN(1)
+ ITRCL = IT -NWOUND(2)
+ ITZRCL = ITZ-NCWOUN(2)
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
+
+ NSTART = NPOINT(4)
+ NEND = NHKK
+
+ 7 CONTINUE
+ DO 8 I=NSTART,NEND
+
+ IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
+* select nucleus the cascade starts first (proj. - 1, target - -1)
+ NCAS = 1
+* projectile/target with probab. 1/2
+ IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
+ IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
+* in the nucleus with highest mass
+ ELSEIF (INCMOD.EQ.2) THEN
+ IF (IP.GT.IT) THEN
+ NCAS = -NCAS
+ ELSEIF (IP.EQ.IT) THEN
+ IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
+ ENDIF
+* the nucleus the cascade starts first is requested to be the one
+* moving in the direction of the secondary
+ ELSEIF (INCMOD.EQ.3) THEN
+ NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
+ ENDIF
+* check that the selected "nucleus" is not a hadron
+ IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
+
+* treat intranuclear cascade in the nucleus selected first
+ LCAS = .FALSE.
+ CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9998
+* treat intranuclear cascade in the other nucleus if this isn't a had.
+ NCAS = -NCAS
+ IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
+ IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9998
+ ENDIF
+
+ ENDIF
+
+ 8 CONTINUE
+ NSTART = NEND+1
+ NEND = NHKK
+ IF (NSTART.LE.NEND) GOTO 7
+
+ RETURN
+
+ 9998 CONTINUE
+* reject this event
+ IRINC = IRINC+1
+ IREJ = 1
+
+ 9999 CONTINUE
+* intranucl. cascade not treated because of interaction properties or
+* it is supressed by user or it was rejected or...
+ LFZC = .FALSE.
+* reset flag characterizing direction of motion in n-n-cms
+**sr14-11-95
+C DO 9990 I=NPOINT(5),NHKK
+C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
+C9990 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_INUCAS.FOR
+*COPY DT_INUCAS
+*
+*===inucas=============================================================*
+*
+ SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
+
+************************************************************************
+* Formation zone supressed IntraNUclear CAScade for one final state *
+* particle. *
+* IT, IP mass numbers of target, projectile nuclei *
+* IDXCAS index of final state particle in DTEVT1 *
+* NCAS = 1 intranuclear cascade in projectile *
+* = -1 intranuclear cascade in target *
+* This version dated 18.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
+ PARAMETER (TWOPI=6.283185307179586454D+00)
+ PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
+
+ LOGICAL LABSOR,LCAS
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+* final state after intranuclear cascade step
+ COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+
+ DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
+ & PCAS1(5),PNUC(5),BGTA(4),
+ & BGCAS(2),GACAS(2),BECAS(2),
+ & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
+
+ DATA PDIF /0.545D0/
+
+ IREJ = 0
+
+* update counter
+ IF (NINCEV(1).NE.NEVHKK) THEN
+ NINCEV(1) = NEVHKK
+ NINCEV(2) = NINCEV(2)+1
+ ENDIF
+
+* "BAMJET-index" of this hadron
+ IDCAS = IDBAM(IDXCAS)
+ IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
+
+* skip gammas, electrons, etc..
+ IF (AAM(IDCAS).LT.TINY2) RETURN
+
+* Lorentz-trsf. into projectile rest system
+ IF (IP.GT.1) THEN
+ CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
+ & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
+ & PCAS(1,4),IDCAS,-2)
+ PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
+ PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
+ IF (PCAS(1,5).GT.ZERO) THEN
+ PCAS(1,5) = SQRT(PCAS(1,5))
+ ELSE
+ PCAS(1,5) = AAM(IDCAS)
+ ENDIF
+ DO 20 K=1,3
+ COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
+ 20 CONTINUE
+* Lorentz-parameters
+* particle rest system --> projectile rest system
+ BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
+ GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
+ BECAS(1) = BGCAS(1)/GACAS(1)
+ ELSE
+ DO 21 K=1,5
+ PCAS(1,K) = ZERO
+ IF (K.LE.3) COSCAS(1,K) = ZERO
+ 21 CONTINUE
+ PTOCAS(1) = ZERO
+ BGCAS(1) = ZERO
+ GACAS(1) = ZERO
+ BECAS(1) = ZERO
+ ENDIF
+* Lorentz-trsf. into target rest system
+ IF (IT.GT.1) THEN
+* LEPTO: final state particles are already in target rest frame
+C IF (MCGENE.EQ.3) THEN
+C PCAS(2,1) = PHKK(1,IDXCAS)
+C PCAS(2,2) = PHKK(2,IDXCAS)
+C PCAS(2,3) = PHKK(3,IDXCAS)
+C PCAS(2,4) = PHKK(4,IDXCAS)
+C ELSE
+ CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
+ & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
+ & PCAS(2,4),IDCAS,-3)
+C ENDIF
+ PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
+ PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
+ IF (PCAS(2,5).GT.ZERO) THEN
+ PCAS(2,5) = SQRT(PCAS(2,5))
+ ELSE
+ PCAS(2,5) = AAM(IDCAS)
+ ENDIF
+ DO 22 K=1,3
+ COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
+ 22 CONTINUE
+* Lorentz-parameters
+* particle rest system --> target rest system
+ BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
+ GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
+ BECAS(2) = BGCAS(2)/GACAS(2)
+ ELSE
+ DO 23 K=1,5
+ PCAS(2,K) = ZERO
+ IF (K.LE.3) COSCAS(2,K) = ZERO
+ 23 CONTINUE
+ PTOCAS(2) = ZERO
+ BGCAS(2) = ZERO
+ GACAS(2) = ZERO
+ BECAS(2) = ZERO
+ ENDIF
+
+* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
+* potential (see CONUCL)
+ RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
+ RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
+* impact parameter (the projectile moving along z)
+ BIMPC(1) = ZERO
+ BIMPC(2) = BIMPAC*FM2MM
+
+* get position of initial hadron in projectile/target rest-syst.
+ DO 3 K=1,4
+ VTXCAS(1,K) = WHKK(K,IDXCAS)
+ VTXCAS(2,K) = VHKK(K,IDXCAS)
+ 3 CONTINUE
+
+ ICAS = 1
+ I2 = 2
+ IF (NCAS.EQ.-1) THEN
+ ICAS = 2
+ I2 = 1
+ ENDIF
+
+ IF (PTOCAS(ICAS).LT.TINY10) THEN
+ WRITE(LOUT,1000) PTOCAS
+ 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
+ & ' hadron ',/,20X,2E12.4)
+ GOTO 9999
+ ENDIF
+
+* reset spectator flags
+ NSPE = 0
+ IDXSPE(1) = 0
+ IDXSPE(2) = 0
+ IDSPE(1) = 0
+ IDSPE(2) = 0
+
+* formation length (in fm)
+C IF (LCAS) THEN
+C DEL0 = ZERO
+C ELSE
+ DEL0 = TAUFOR*BGCAS(ICAS)
+ IF (ITAUVE.EQ.1) THEN
+ AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
+ DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
+ ENDIF
+C ENDIF
+* sample from exp(-del/del0)
+ DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
+* save formation time
+ TAUSA1 = DEL1/BGCAS(ICAS)
+ REL1 = TAUSA1*BGCAS(I2)
+
+ DEL = DEL1
+ TAUSAM = DEL/BGCAS(ICAS)
+ REL = TAUSAM*BGCAS(I2)
+
+* special treatment for negative particles unable to escape
+* nuclear potential (implemented for ap, pi-, K- only)
+ LABSOR = .FALSE.
+ IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
+* threshold energy = nuclear potential + Coulomb potential
+* (nuclear potential for hadron-nucleus interactions only)
+ ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
+ IF (PCAS(ICAS,4).LT.ETHR) THEN
+ DO 4 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ 4 CONTINUE
+* "absorb" negative particle in nucleus
+ CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (NSPE.GE.1) LABSOR = .TRUE.
+ ENDIF
+ ENDIF
+
+* if the initial particle has not been absorbed proceed with
+* "normal" cascade
+ IF (.NOT.LABSOR) THEN
+
+* calculate coordinates of hadron at the end of the formation zone
+* transport-time and -step in the rest system where this step is
+* treated
+ DSTEP = DEL*FM2MM
+ DTIME = DSTEP/BECAS(ICAS)
+ RSTEP = REL*FM2MM
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME = RSTEP/BECAS(I2)
+ ELSE
+ RTIME = ZERO
+ ENDIF
+* save step whithout considering the overlapping region
+ DSTEP1 = DEL1*FM2MM
+ DTIME1 = DSTEP1/BECAS(ICAS)
+ RSTEP1 = REL1*FM2MM
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME1 = RSTEP1/BECAS(I2)
+ ELSE
+ RTIME1 = ZERO
+ ENDIF
+* transport to the end of the formation zone in this system
+ DO 5 K=1,3
+ VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
+ VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
+ VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
+ VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
+ 5 CONTINUE
+ VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
+ VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
+ VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
+ VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
+
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ XCAS = VTXCAS(ICAS,1)
+ YCAS = VTXCAS(ICAS,2)
+ XNCLTA = BIMPAC*FM2MM
+ RNCLPR = (RPROJ+RNUCLE)*FM2MM
+ RNCLTA = (RTARG+RNUCLE)*FM2MM
+C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
+C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
+C RNCLPR = (RPROJ)*FM2MM
+C RNCLTA = (RTARG)*FM2MM
+ RCASPR = SQRT( XCAS**2 +YCAS**2)
+ RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
+ IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
+ IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
+ ENDIF
+ ENDIF
+
+* check if particle is already outside of the corresp. nucleus
+ RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
+ & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
+ IF (RDIST.GE.RNUC(ICAS)) THEN
+* here: IDCH is the generation of the final state part. starting
+* with zero for hadronization products
+* flag particles of generation 0 being outside the nuclei after
+* formation time (to be used for excitation energy calculation)
+ IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
+ & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
+ GOTO 9997
+ ENDIF
+ DIST = DLARGE
+ DISTP = DLARGE
+ DISTN = DLARGE
+ IDXP = 0
+ IDXN = 0
+
+* already here: skip particles being outside HADRIN "energy-window"
+* to avoid wasting of time
+ NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
+ IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
+ NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
+C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
+C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
+C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
+C & E12.4,', above or below HADRIN-thresholds',I6)
+ NSPE = 0
+ GOTO 9997
+ ENDIF
+
+ DO 7 IDXHKK=1,NOINC
+ I = IDXINC(IDXHKK)
+* scan DTEVT1 for unwounded or excited nucleons
+ IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
+ DO 8 K=1,3
+ IF (ICAS.EQ.1) THEN
+ VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
+ ELSEIF (ICAS.EQ.2) THEN
+ VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
+ ENDIF
+ 8 CONTINUE
+ POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
+ & VTXDST(2)*COSCAS(ICAS,2)+
+ & VTXDST(3)*COSCAS(ICAS,3)
+* check if nucleon is situated in forward direction
+ IF (POSNUC.GT.ZERO) THEN
+* distance between hadron and this nucleon
+ DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+ & VTXDST(3)**2)
+* impact parameter
+ BIMNU2 = DISTNU**2-POSNUC**2
+ IF (BIMNU2.LT.ZERO) THEN
+ WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
+ 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
+ & ' parameter ',/,20X,3E12.4)
+ GOTO 7
+ ENDIF
+ BIMNU = SQRT(BIMNU2)
+* maximum impact parameter to have interaction
+ IDNUC = IDT_ICIHAD(IDHKK(I))
+ IDNUC1 = IDT_MCHAD(IDNUC)
+ IDCAS1 = IDT_MCHAD(IDCAS)
+ DO 19 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ PNUC(K) = PHKK(K,I)
+ 19 CONTINUE
+* Lorentz-parameter for trafo into rest-system of target
+ DO 18 K=1,4
+ BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
+ 18 CONTINUE
+* transformation of projectile into rest-system of target
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
+ & PPTOT,PX,PY,PZ,PE)
+**
+C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
+C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
+ DUMZER = ZERO
+ CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
+ CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
+ IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
+ & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
+ SIGIN = SIGTOT-SIGEL-SIGAB
+C SIGTOT = SIGIN+SIGEL+SIGAB
+**
+ BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
+* check if interaction is possible
+ IF (BIMNU.LE.BIMMAX) THEN
+* get nucleon with smallest distance and kind of interaction
+* (elastic/inelastic)
+ IF (DISTNU.LT.DIST) THEN
+ DIST = DISTNU
+ BINT = BIMNU
+ IF (IDNUC.NE.IDSPE(1)) THEN
+ IDSPE(2) = IDSPE(1)
+ IDXSPE(2) = IDXSPE(1)
+ IDSPE(1) = IDNUC
+ ENDIF
+ IDXSPE(1) = I
+ NSPE = 1
+**sr
+ SELA = SIGEL
+ SABS = SIGAB
+ STOT = SIGTOT
+C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
+C SELA = SIGEL
+C STOT = SIGIN+SIGEL
+C ELSE
+C SELA = SIGEL+0.75D0*SIGIN
+C STOT = 0.25D0*SIGIN+SELA
+C ENDIF
+**
+ ENDIF
+ ENDIf
+ ENDIF
+ DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+ & VTXDST(3)**2)
+ IDNUC = IDT_ICIHAD(IDHKK(I))
+ IF (IDNUC.EQ.1) THEN
+ IF (DISTNU.LT.DISTP) THEN
+ DISTP = DISTNU
+ IDXP = I
+ POSP = POSNUC
+ ENDIF
+ ELSEIF (IDNUC.EQ.8) THEN
+ IF (DISTNU.LT.DISTN) THEN
+ DISTN = DISTNU
+ IDXN = I
+ POSN = POSNUC
+ ENDIF
+ ENDIF
+ ENDIF
+ 7 CONTINUE
+
+* there is no nucleon for a secondary interaction
+ IF (NSPE.EQ.0) GOTO 9997
+
+C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
+C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
+ IF (IDXSPE(2).EQ.0) THEN
+ IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
+C DO 80 K=1,3
+C IF (ICAS.EQ.1) THEN
+C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
+C ELSEIF (ICAS.EQ.2) THEN
+C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
+C ENDIF
+C 80 CONTINUE
+C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+C & VTXDST(3)**2)
+C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
+ IDXSPE(2) = IDXN
+ IDSPE(2) = 8
+C ELSE
+C STOT = STOT-SABS
+C SABS = ZERO
+C ENDIF
+ ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
+C DO 81 K=1,3
+C IF (ICAS.EQ.1) THEN
+C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
+C ELSEIF (ICAS.EQ.2) THEN
+C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
+C ENDIF
+C 81 CONTINUE
+C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+C & VTXDST(3)**2)
+C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
+ IDXSPE(2) = IDXP
+ IDSPE(2) = 1
+C ELSE
+C STOT = STOT-SABS
+C SABS = ZERO
+C ENDIF
+ ELSE
+ STOT = STOT-SABS
+ SABS = ZERO
+ ENDIF
+ ENDIF
+ RR = DT_RNDM(DIST)
+ IF (RR.LT.SELA/STOT) THEN
+ IPROC = 2
+ ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
+ IPROC = 3
+ ELSE
+ IPROC = 1
+ ENDIF
+
+ DO 9 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ PNUC(K) = PHKK(K,IDXSPE(1))
+ 9 CONTINUE
+ IF (IPROC.EQ.3) THEN
+* 2-nucleon absorption of pion
+ NSPE = 2
+ CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (NSPE.GE.1) LABSOR = .TRUE.
+ ELSE
+* sample secondary interaction
+ IDNUC = IDBAM(IDXSPE(1))
+ CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
+ IF (IREJ1.EQ.1) GOTO 9999
+ IF (IREJ1.GT.1) GOTO 9998
+ ENDIF
+ ENDIF
+
+* update arrays to include Pauli-principle
+ DO 10 I=1,NSPE
+ IF (NWOUND(ICAS).LE.299) THEN
+ NWOUND(ICAS) = NWOUND(ICAS)+1
+ EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
+ ENDIF
+ 10 CONTINUE
+
+* dump initial hadron for energy-momentum conservation check
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
+ & PCAS(ICAS,4),1,IDUM,IDUM)
+
+* dump final state particles into DTEVT1
+
+* check if Pauli-principle is fulfilled
+ NPAULI = 0
+ NWTMP(1) = NWOUND(1)
+ NWTMP(2) = NWOUND(2)
+ DO 111 I=1,NFSP
+ NPAULI = 0
+ J1 = 2
+ IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
+ DO 117 J=1,J1
+ IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
+ IF (J.EQ.1) THEN
+ IDX = ICAS
+ PE = PFSP(4,I)
+ ELSE
+ IDX = I2
+ MODE = 1
+ IF (IDX.EQ.1) MODE = -1
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
+ ENDIF
+* first check if cascade step is forbidden due to Pauli-principle
+* (in case of absorpion this step is forced)
+ IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
+ & (IDFSP(I).EQ.8))) THEN
+* get nuclear potential barrier
+ POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
+ IF (IDFSP(I).EQ.1) THEN
+ POTLOW = POT-EBINDP(IDX)
+ ELSE
+ POTLOW = POT-EBINDN(IDX)
+ ENDIF
+* final state particle not able to escape nucleus
+ IF (PE.LE.POTLOW) THEN
+* check if there are wounded nucleons
+ IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
+ & EWOUND(IDX,NWOUND(IDX)))) THEN
+ NPAULI = NPAULI+1
+ NWOUND(IDX) = NWOUND(IDX)-1
+ ELSE
+* interaction prohibited by Pauli-principle
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+ GOTO 9997
+ ENDIF
+ ENDIF
+ ENDIF
+ 117 CONTINUE
+ 111 CONTINUE
+
+ NPAULI = 0
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+
+ DO 11 I=1,NFSP
+
+ IST = ISTHKK(IDXCAS)
+
+ NPAULI = 0
+ J1 = 2
+ IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
+ DO 17 J=1,J1
+ IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
+ IDX = ICAS
+ PE = PFSP(4,I)
+ IF (J.EQ.2) THEN
+ IDX = I2
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
+ ENDIF
+* first check if cascade step is forbidden due to Pauli-principle
+* (in case of absorpion this step is forced)
+ IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
+ & (IDFSP(I).EQ.8))) THEN
+* get nuclear potential barrier
+ POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
+ IF (IDFSP(I).EQ.1) THEN
+ POTLOW = POT-EBINDP(IDX)
+ ELSE
+ POTLOW = POT-EBINDN(IDX)
+ ENDIF
+* final state particle not able to escape nucleus
+ IF (PE.LE.POTLOW) THEN
+* check if there are wounded nucleons
+ IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
+ & EWOUND(IDX,NWOUND(IDX)))) THEN
+ NWOUND(IDX) = NWOUND(IDX)-1
+ NPAULI = NPAULI+1
+ IST = 14+IDX
+ ELSE
+* interaction prohibited by Pauli-principle
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+ GOTO 9997
+ ENDIF
+**sr
+c ELSEIF (PE.LE.POT) THEN
+cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
+cC NWOUND(IDX) = NWOUND(IDX)-1
+c**
+c NPAULI = NPAULI+1
+c IST = 14+IDX
+ ENDIF
+ ENDIF
+ 17 CONTINUE
+
+* dump final state particles for energy-momentum conservation check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
+ & -PFSP(4,I),2,IDUM,IDUM)
+
+ PX = PFSP(1,I)
+ PY = PFSP(2,I)
+ PZ = PFSP(3,I)
+ PE = PFSP(4,I)
+ IF (ABS(IST).EQ.1) THEN
+* transform particles back into n-n cms
+* LEPTO: leave final state particles in target rest frame
+C IF (MCGENE.EQ.3) THEN
+C PFSP(1,I) = PX
+C PFSP(2,I) = PY
+C PFSP(3,I) = PZ
+C PFSP(4,I) = PE
+C ELSE
+ IMODE = ICAS+1
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),IMODE)
+C ENDIF
+ ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
+* target cascade but fsp got stuck in proj. --> transform it into
+* proj. rest system
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),-1)
+ ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
+* proj. cascade but fsp got stuck in target --> transform it into
+* target rest system
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),1)
+ ENDIF
+
+* dump final state particles into DTEVT1
+ IGEN = IDCH(IDXCAS)+1
+ ID = IDT_IPDGHA(IDFSP(I))
+ IXR = 0
+ IF (LABSOR) IXR = 99
+ CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
+ & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
+
+* update the counter for particles which got stuck inside the nucleus
+ IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
+ NOINC = NOINC+1
+ IDXINC(NOINC) = NHKK
+ ENDIF
+ IF (LABSOR) THEN
+* in case of absorption the spatial treatment is an approximate
+* solution anyway (the positions of the nucleons which "absorb" the
+* cascade particle are not taken into consideration) therefore the
+* particles are produced at the position of the cascade particle
+ DO 12 K=1,4
+ WHKK(K,NHKK) = WHKK(K,IDXCAS)
+ VHKK(K,NHKK) = VHKK(K,IDXCAS)
+ 12 CONTINUE
+ ELSE
+* DDISTL - distance the cascade particle moves to the intera. point
+* (the position where impact-parameter = distance to the interacting
+* nucleon), DIST - distance to the interacting nucleon at the time of
+* formation of the cascade particle, BINT - impact-parameter of this
+* cascade-interaction
+ DDISTL = SQRT(DIST**2-BINT**2)
+ DTIME = DDISTL/BECAS(ICAS)
+ DTIMEL = DDISTL/BGCAS(ICAS)
+ RDISTL = DTIMEL*BGCAS(I2)
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME = RDISTL/BECAS(I2)
+ ELSE
+ RTIME = ZERO
+ ENDIF
+* RDISTL, RTIME are this step and time in the rest system of the other
+* nucleus
+ DO 13 K=1,3
+ VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
+ VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
+ 13 CONTINUE
+ VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
+ VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
+* position of particle production is half the impact-parameter to
+* the interacting nucleon
+ DO 14 K=1,3
+ WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
+ VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
+ 14 CONTINUE
+* time of production of secondary = time of interaction
+ WHKK(4,NHKK) = VTXCA1(1,4)
+ VHKK(4,NHKK) = VTXCA1(2,4)
+ ENDIF
+
+ 11 CONTINUE
+
+* modify status and position of cascade particle (the latter for
+* statistics reasons only)
+ ISTHKK(IDXCAS) = 2
+ IF (LABSOR) ISTHKK(IDXCAS) = 19
+ IF (.NOT.LABSOR) THEN
+ DO 15 K=1,4
+ WHKK(K,IDXCAS) = VTXCA1(1,K)
+ VHKK(K,IDXCAS) = VTXCA1(2,K)
+ 15 CONTINUE
+ ENDIF
+
+ DO 16 I=1,NSPE
+ IS = IDXSPE(I)
+* dump interacting nucleons for energy-momentum conservation check
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
+ & 2,IDUM,IDUM)
+* modify entry for interacting nucleons
+ IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
+ IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
+ IF (I.GE.2) THEN
+ JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
+ JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
+ ENDIF
+ 16 CONTINUE
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+* update counter
+ IF (LABSOR) THEN
+ NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
+ ELSE
+ IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
+ IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
+ ENDIF
+
+ RETURN
+
+ 9997 CONTINUE
+ 9998 CONTINUE
+* transport-step but no cascade step due to configuration (i.e. there
+* is no nucleon for interaction etc.)
+ IF (LCAS) THEN
+ DO 100 K=1,4
+C WHKK(K,IDXCAS) = VTXCAS(1,K)
+C VHKK(K,IDXCAS) = VTXCAS(2,K)
+ WHKK(K,IDXCAS) = VTXCA1(1,K)
+ VHKK(K,IDXCAS) = VTXCA1(2,K)
+ 100 CONTINUE
+ ENDIF
+
+C9998 CONTINUE
+* no cascade-step because of configuration
+* (i.e. hadron outside nucleus etc.)
+ LCAS = .TRUE.
+ RETURN
+
+ 9999 CONTINUE
+* rejection
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_ABSORP.FOR
+*COPY DT_ABSORP
+*
+*===absorp=============================================================*
+*
+ SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
+
+************************************************************************
+* Two-nucleon absorption of antiprotons, pi-, and K-. *
+* Antiproton absorption is handled by HADRIN. *
+* The following channels for meson-absorption are considered: *
+* pi- + p + p ---> n + p *
+* pi- + p + n ---> n + n *
+* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
+* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
+* K- + p + p ---> sigma- + n *
+* IDCAS, PCAS identity, momentum of particle to be absorbed *
+* NCAS = 1 intranuclear cascade in projectile *
+* = -1 intranuclear cascade in target *
+* NSPE number of spectator nucleons involved *
+* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
+* Revised version of the original STOPIK written by HJM and J. Ranft. *
+* This version dated 24.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
+ & ONETHI=0.3333D0,TWOTHI=0.6666D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
+ & PTOT3P(4),BG3P(4),
+ & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
+
+ IREJ = 0
+ NFSP = 0
+
+* skip particles others than ap, pi-, K- for mode=0
+ IF ((MODE.EQ.0).AND.
+ & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
+* skip particles others than pions for mode=1
+* (2-nucleon absorption in intranuclear cascade)
+ IF ((MODE.EQ.1).AND.
+ & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
+
+ NUCAS = NCAS
+ IF (NUCAS.EQ.-1) NUCAS = 2
+
+ IF (MODE.EQ.0) THEN
+* scan spectator nucleons for nucleons being able to "absorb"
+ NSPE = 0
+ IDXSPE(1) = 0
+ IDXSPE(2) = 0
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
+ NSPE = NSPE+1
+ IDXSPE(NSPE) = I
+ IDSPE(NSPE) = IDBAM(I)
+ IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
+ IF (NSPE.EQ.2) THEN
+ IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
+ & (IDSPE(2).EQ.8)) THEN
+* there is no pi-+n+n channel
+ NSPE = 1
+ GOTO 1
+ ELSE
+ GOTO 2
+ ENDIF
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ 2 CONTINUE
+ ENDIF
+* transform excited projectile nucleons (status=15) into proj. rest s.
+ DO 3 I=1,NSPE
+ DO 4 K=1,5
+ PSPE(I,K) = PHKK(K,IDXSPE(I))
+ 4 CONTINUE
+ 3 CONTINUE
+
+* antiproton absorption
+ IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
+ DO 5 K=1,5
+ PSPE1(K) = PSPE(1,K)
+ 5 CONTINUE
+ CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+* meson absorption
+ ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
+ & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
+ IF (IDCAS.EQ.14) THEN
+* pi- absorption
+ IDFSP(1) = 8
+ IDFSP(2) = 8
+ IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
+ ELSEIF (IDCAS.EQ.13) THEN
+* pi+ absorption
+ IDFSP(1) = 1
+ IDFSP(2) = 1
+ IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
+ ELSEIF (IDCAS.EQ.23) THEN
+* pi0 absorption
+ IDFSP(1) = IDSPE(1)
+ IDFSP(2) = IDSPE(2)
+ ELSEIF (IDCAS.EQ.16) THEN
+* K- absorption
+ R = DT_RNDM(PCAS)
+ IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
+ IF (R.LT.ONETHI) THEN
+ IDFSP(1) = 21
+ IDFSP(2) = 8
+ ELSEIF (R.LT.TWOTHI) THEN
+ IDFSP(1) = 17
+ IDFSP(2) = 1
+ ELSE
+ IDFSP(1) = 22
+ IDFSP(2) = 1
+ ENDIF
+ ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
+ IDFSP(1) = 20
+ IDFSP(2) = 8
+ ELSE
+ IF (R.LT.ONETHI) THEN
+ IDFSP(1) = 20
+ IDFSP(2) = 1
+ ELSEIF (R.LT.TWOTHI) THEN
+ IDFSP(1) = 17
+ IDFSP(2) = 8
+ ELSE
+ IDFSP(1) = 22
+ IDFSP(2) = 8
+ ENDIF
+ ENDIF
+ ENDIF
+* dump initial particles for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
+ & IDUM,IDUM)
+ CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
+ & IDUM,IDUM)
+ ENDIF
+* get Lorentz-parameter of 3 particle initial state
+ DO 6 K=1,4
+ PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
+ 6 CONTINUE
+ P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
+ AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
+ DO 7 K=1,4
+ BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
+ 7 CONTINUE
+* 2-particle decay of the 3-particle compound system
+ CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & AAM(IDFSP(1)),AAM(IDFSP(2)))
+ DO 8 I=1,2
+ SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
+ PX = PCMF(I)*COFF(I)*SDF
+ PY = PCMF(I)*SIFF(I)*SDF
+ PZ = PCMF(I)*CODF(I)
+ CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
+ & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I))
+ PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
+* check consistency of kinematics
+ IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
+ WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
+ 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
+ & ' tree-particle kinematics',/,20X,'id: ',I3,
+ & ' AAM = ',E10.4,' MFSP = ',E10.4)
+ ENDIF
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
+ & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
+ 8 CONTINUE
+ NFSP = 2
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
+ & AM3P
+ GOTO 9999
+ ENDIF
+ ENDIF
+ ELSE
+ IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
+ 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
+ & ' impossible',/,20X,'too few spectators (',I2,')')
+ NSPE = 0
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_HADRIN.FOR
+*COPY DT_HADRIN
+*
+*===hadrin=============================================================*
+*
+ SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
+
+************************************************************************
+* Interface to the HADRIN-routines for inelastic and elastic *
+* scattering. *
+* IDPR,PPR(5) identity, momentum of projectile *
+* IDTA,PTA(5) identity, momentum of target *
+* MODE = 1 inelastic interaction *
+* = 2 elastic interaction *
+* Revised version of the original FHAD. *
+* This version dated 27.10.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
+ & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
+
+ LOGICAL LCORR,LMSSG
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+* output-common for DHADRI/ELHAIN
+
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+ DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
+ & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
+
+ DATA LMSSG /.TRUE./
+
+ IREJ = 0
+ NFSP = 0
+ KCORR = 0
+ IMCORR(1) = 0
+ IMCORR(2) = 0
+ LCORR = .FALSE.
+
+* dump initial particles for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
+ ENDIF
+
+ AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
+ AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
+ IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
+ & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
+ & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
+ IF (LMSSG.AND.(IOULEV(3).GT.0))
+ & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
+ 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
+ & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
+ & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
+ LMSSG = .FALSE.
+ LCORR = .TRUE.
+ ENDIF
+
+* convert initial state particles into particles which can be
+* handled by HADRIN
+ IDHPR = IDPR
+ IDHTA = IDTA
+ IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
+ IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
+ DO 1 K=1,4
+ P1IN(K) = PPR(K)
+ P2IN(K) = PTA(K)
+ 1 CONTINUE
+ XM1 = AAM(IDHPR)
+ XM2 = AAM(IDHTA)
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
+ GOTO 9999
+ ENDIF
+ DO 2 K=1,4
+ PPR(K) = P1OUT(K)
+ PTA(K) = P2OUT(K)
+ 2 CONTINUE
+ PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
+ PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
+ ENDIF
+
+* Lorentz-parameter for trafo into rest-system of target
+ DO 3 K=1,4
+ BGTA(K) = PTA(K)/PTA(5)
+ 3 CONTINUE
+* transformation of projectile into rest-system of target
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
+ & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
+ & PPR1(4))
+
+* direction cosines of projectile in target rest system
+ CX = PPR1(1)/PPRTO1
+ CY = PPR1(2)/PPRTO1
+ CZ = PPR1(3)/PPRTO1
+
+* sample inelastic interaction
+ IF (MODE.EQ.1) THEN
+ CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
+ IF (IRH.EQ.1) GOTO 9998
+* sample elastic interaction
+ ELSEIF (MODE.EQ.2) THEN
+ CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
+ GOTO 9999
+ ENDIF
+ IF (IRH.EQ.1) GOTO 9998
+ ELSE
+ WRITE(LOUT,1001) MODE,INTHAD
+ 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
+ & I4,' (INTHAD =',I4,')')
+ GOTO 9999
+ ENDIF
+
+* transform final state particles back into Lab.
+ DO 4 I=1,IRH
+ NFSP = NFSP+1
+ PX = CXRH(I)*PLRH(I)
+ PY = CYRH(I)*PLRH(I)
+ PZ = CZRH(I)*PLRH(I)
+ CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
+ & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
+ & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
+ IDFSP(NFSP) = ITRH(I)
+ AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
+ & PFSP(3,NFSP)**2
+ IF (AMFSP2.LT.-TINY3) THEN
+ WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
+ & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
+ 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
+ & I2,') with negative mass^2',/,1X,5E12.4)
+ GOTO 9999
+ ELSE
+ PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
+ IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
+ WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
+ & PFSP(5,NFSP)
+ 1003 FORMAT(1X,'HADRIN: warning! final state particle',
+ & ' (id = ',I2,') with inconsistent mass',/,1X,
+ & 2E12.4)
+ KCORR = KCORR+1
+ IF (KCORR.GT.2) GOTO 9999
+ IMCORR(KCORR) = NFSP
+ ENDIF
+ ENDIF
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
+ & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
+ 4 CONTINUE
+
+* transform momenta on mass shell in case of inconsistencies in
+* HADRIN
+ IF (KCORR.GT.0) THEN
+ IF (KCORR.EQ.2) THEN
+ I1 = IMCORR(1)
+ I2 = IMCORR(2)
+ ELSE
+ IF (IMCORR(1).EQ.1) THEN
+ I1 = 1
+ I2 = 2
+ ELSE
+ I1 = 1
+ I2 = IMCORR(1)
+ ENDIF
+ ENDIF
+ IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
+ & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
+ IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
+ & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
+ DO 5 K=1,4
+ P1IN(K) = PFSP(K,I1)
+ P2IN(K) = PFSP(K,I2)
+ 5 CONTINUE
+ XM1 = AAM(IDFSP(I1))
+ XM2 = AAM(IDFSP(I2))
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
+C GOTO 9999
+ ENDIF
+ DO 6 K=1,4
+ PFSP(K,I1) = P1OUT(K)
+ PFSP(K,I2) = P2OUT(K)
+ 6 CONTINUE
+ PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
+ & -PFSP(2,I1)**2-PFSP(3,I1)**2)
+ PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
+ & -PFSP(2,I2)**2-PFSP(3,I2)**2)
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
+ & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
+ & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
+ ENDIF
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+ RETURN
+
+ 9998 CONTINUE
+ IREJ = 2
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_HADCOL.FOR
+*COPY DT_HADCOL
+*
+*===hadcol=============================================================*
+*
+ SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
+
+************************************************************************
+* Interface to the HADRIN-routines for inelastic and elastic *
+* scattering. This subroutine samples hadron-nucleus interactions *
+* below DPM-threshold. *
+* IDPROJ BAMJET-index of projectile hadron *
+* PPN projectile momentum in target rest frame *
+* IDXTAR DTEVT1-index of target nucleon undergoing *
+* interaction with projectile hadron *
+* This subroutine replaces HADHAD. *
+* This version dated 5.5.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
+
+ LOGICAL LSTART
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* interface HADRIN-DPM
+ COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION PPROJ(5),PNUC(5)
+
+ DATA LSTART /.TRUE./
+
+ IREJ = 0
+
+ NPOINT(1) = NHKK+1
+
+ TAUSAV = TAUFOR
+**sr 6/9/01 commented
+C TAUFOR = TAUFOR/2.0D0
+**
+ IF (LSTART) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
+ WRITE(LOUT,1001) TAUFOR
+ 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
+ & F5.1,' fm/c')
+ LSTART = .FALSE.
+ ENDIF
+
+ IDNUC = IDBAM(IDXTAR)
+ IDNUC1 = IDT_MCHAD(IDNUC)
+ IDPRO1 = IDT_MCHAD(IDPROJ)
+
+ IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
+ IPROC = INTHAD
+ ELSE
+**
+C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
+C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
+ DUMZER = ZERO
+ CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
+ SIGIN = SIGTOT-SIGEL
+C SIGTOT = SIGIN+SIGEL
+**
+ IPROC = 1
+ IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
+ ENDIF
+
+ PPROJ(1) = ZERO
+ PPROJ(2) = ZERO
+ PPROJ(3) = PPN
+ PPROJ(5) = AAM(IDPROJ)
+ PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
+ DO 1 K=1,5
+ PNUC(K) = PHKK(K,IDXTAR)
+ 1 CONTINUE
+
+ ILOOP = 0
+ 2 CONTINUE
+ ILOOP = ILOOP+1
+ IF (ILOOP.GT.100) GOTO 9999
+
+ CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
+ IF (IREJ1.EQ.1) GOTO 9999
+
+ IF (IREJ1.GT.1) THEN
+* no interaction possible
+* require Pauli blocking
+ IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
+ IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
+ IF ((IIBAR(IDPROJ).NE.1).AND.
+ & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
+* store incoming particle as final state particle
+ CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
+ CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
+ NPOINT(4) = NHKK
+ ELSE
+* require Pauli blocking for final state nucleons
+ DO 4 I=1,NFSP
+ IF ((IDFSP(I).EQ.1).AND.
+ & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
+ IF ((IDFSP(I).EQ.8).AND.
+ & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
+ IF ((IIBAR(IDFSP(I)).NE.1).AND.
+ & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
+ 4 CONTINUE
+* store final state particles
+ DO 5 I=1,NFSP
+ IST = 1
+ IF ((IIBAR(IDFSP(I)).EQ.1).AND.
+ & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
+ IDHAD = IDT_IPDGHA(IDFSP(I))
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
+ CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
+ & PCMS,ECMS,0,0,0)
+ IF (I.EQ.1) NPOINT(4) = NHKK
+ VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
+ VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
+ VHKK(3,NHKK) = VHKK(3,IDXTAR)
+ VHKK(4,NHKK) = VHKK(4,IDXTAR)
+ WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
+ WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
+ WHKK(3,NHKK) = WHKK(3,1)
+ WHKK(4,NHKK) = WHKK(4,1)
+ 5 CONTINUE
+ ENDIF
+ TAUFOR = TAUSAV
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ TAUFOR = TAUSAV
+ RETURN
+ END
+*$ CREATE DT_GETEMU.FOR
+*COPY DT_GETEMU
+*
+*===getemu=============================================================*
+*
+ SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
+
+************************************************************************
+* Sampling of emulsion component to be considered as target-nucleus. *
+* This version dated 6.5.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ IF (MODE.EQ.0) THEN
+ SUMFRA = ZERO
+ RR = DT_RNDM(SUMFRA)
+ IT = 0
+ ITZ = 0
+ DO 1 ICOMP=1,NCOMPO
+ SUMFRA = SUMFRA+EMUFRA(ICOMP)
+ IF (SUMFRA.GT.RR) THEN
+ IT = IEMUMA(ICOMP)
+ ITZ = IEMUCH(ICOMP)
+ KKMAT = ICOMP
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ IF (IT.LE.0) THEN
+ WRITE(LOUT,'(1X,A,E12.3)')
+ & 'Warning! norm. failure within emulsion fractions',
+ & SUMFRA
+ STOP
+ ENDIF
+ ELSEIF (MODE.EQ.1) THEN
+ NDIFF = 10000
+ DO 3 I=1,NCOMPO
+ IDIFF = ABS(IT-IEMUMA(I))
+ IF (IDIFF.LT.NDIFF) THEN
+ KKMAT = I
+ NDIFF = IDIFF
+ ENDIF
+ 3 CONTINUE
+ ELSE
+ STOP 'DT_GETEMU'
+ ENDIF
+
+* bypass for variable projectile/target/energy runs: the correct
+* Glauber data will be always loaded on kkmat=1
+ IF (IOGLB.EQ.100) THEN
+ KKMAT = 1
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_NCLPOT.FOR
+*COPY DT_NCLPOT
+*
+*===nclpot=============================================================*
+*
+ SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
+
+************************************************************************
+* Calculation of Coulomb and nuclear potential for a given configurat. *
+* IPZ, IP charge/mass number of proj. *
+* ITZ, IT charge/mass number of targ. *
+* AFERP,AFERT factors modifying proj./target pot. *
+* if =0, FERMOD is used *
+* MODE = 0 calculation of binding energy *
+* = 1 pre-calculated binding energy is used *
+* This version dated 16.11.95 is written by S. Roesler. *
+* *
+* Last change 28.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
+ & TINY10=1.0D-10)
+
+ LOGICAL LSTART
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+ DIMENSION IDXPOT(14)
+* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
+ DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
+* asig0 asig+ atet0 atet+
+ & 100, 101, 102, 103/
+
+ DATA AN /0.4D0/
+ DATA LSTART /.TRUE./
+
+ IF (MODE.EQ.0) THEN
+ EBINDP(1) = ZERO
+ EBINDN(1) = ZERO
+ EBINDP(2) = ZERO
+ EBINDN(2) = ZERO
+ ENDIF
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+ FERMIP = AFERP
+ IF (AFERP.LE.ZERO) FERMIP = FERMOD
+ FERMIT = AFERT
+ IF (AFERT.LE.ZERO) FERMIT = FERMOD
+
+* Fermi momenta and binding energy for projectile
+ IF ((IP.GT.1).AND.LFERMI) THEN
+ IF (MODE.EQ.0) THEN
+C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
+C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
+ BIP = AIP -ONE
+ BIPZ = AIPZ-ONE
+
+C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
+C & -ENERGY(AIP,AIPZ))
+ EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
+ & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
+ & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
+
+ IF (AIP.LE.AIPZ) THEN
+ EBINDN(1) = EBINDP(1)
+ WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
+ ELSE
+
+C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
+C & -ENERGY(AIP,AIPZ))
+ EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
+ & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
+ & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
+
+ ENDIF
+ ENDIF
+ PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
+ PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
+ ELSE
+ PFERMP(1) = ZERO
+ PFERMN(1) = ZERO
+ ENDIF
+* effective nuclear potential for projectile
+C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
+C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
+ EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
+ EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
+
+* Fermi momenta and binding energy for target
+ IF ((IT.GT.1).AND.LFERMI) THEN
+ IF (MODE.EQ.0) THEN
+C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
+C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
+ BIT = AIT -ONE
+ BITZ = AITZ-ONE
+
+C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
+C & -ENERGY(AIT,AITZ))
+ EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
+ & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
+ & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
+
+ IF (AIT.LE.AITZ) THEN
+ EBINDN(2) = EBINDP(2)
+ WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
+ ELSE
+
+C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
+C & -ENERGY(AIT,AITZ))
+ EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
+ & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
+ & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
+
+ ENDIF
+ ENDIF
+ PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
+ PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
+ ELSE
+ PFERMP(2) = ZERO
+ PFERMN(2) = ZERO
+ ENDIF
+* effective nuclear potential for target
+C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
+C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
+ EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
+ EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
+
+ DO 2 I=1,14
+ EPOT(1,IDXPOT(I)) = EPOT(1,8)
+ EPOT(2,IDXPOT(I)) = EPOT(2,8)
+ 2 CONTINUE
+
+* Coulomb energy
+ ETACOU(1) = ZERO
+ ETACOU(2) = ZERO
+ IF (ICOUL.EQ.1) THEN
+ IF (IP.GT.1)
+ & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
+ IF (IT.GT.1)
+ & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
+ ENDIF
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
+ & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
+ & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
+ & FERMOD,ETACOU
+ 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
+ & ,' effects',/,12X,'---------------------------',
+ & '----------------',/,/,38X,'projectile',
+ & ' target',/,/,1X,'Mass number / charge',
+ & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
+ & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
+ & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
+ & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
+ & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
+ & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
+ LSTART = .FALSE.
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_RESNCL.FOR
+*COPY DT_RESNCL
+*
+*===resncl=============================================================*
+*
+ SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
+
+************************************************************************
+* Treatment of residual nuclei and nuclear effects. *
+* MODE = 1 initializations *
+* = 2 treatment of final state *
+* This version dated 16.11.95 is written by S. Roesler. *
+* *
+* Last change 05.01.2007 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
+ & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
+ & ONETHI=ONE/THREE)
+ PARAMETER (AMUAMU = 0.93149432D0,
+ & FM2MM = 1.0D-12,
+ & RNUCLE = 1.12D0)
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMPRTN = 0.93827231 D+00 )
+ PARAMETER ( AMNTRN = 0.93956563 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( FERTHO = 14.33 D-09 )
+ PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
+ PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
+ PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* treatment of residual nuclei: wounded nucleons
+ COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
+
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+
+ DIMENSION PFSP(4),PSEC(4),PSEC0(4)
+ DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
+ & IDXCOR(15000),IDXOTH(NMXHKK)
+
+ GOTO (1,2) MODE
+
+*------- initializations
+ 1 CONTINUE
+
+* initialize arrays for residual nuclei
+ DO 10 K=1,5
+ IF (K.LE.4) THEN
+ PFSP(K) = ZERO
+ ENDIF
+ PINIPR(K) = ZERO
+ PINITA(K) = ZERO
+ PRCLPR(K) = ZERO
+ PRCLTA(K) = ZERO
+ TRCLPR(K) = ZERO
+ TRCLTA(K) = ZERO
+ 10 CONTINUE
+ SCPOT = ONE
+ NLOOP = 0
+
+* correction of projectile 4-momentum for effective target pot.
+* and Coulomb-energy (in case of hadron-nucleus interaction only)
+ IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
+ EPNI = EPN
+* Coulomb-energy:
+* positively charged hadron - check energy for Coloumb pot.
+ IF (IICH(IJPROJ).EQ.1) THEN
+ THRESH = ETACOU(2)+AAM(IJPROJ)
+ IF (EPNI.LE.THRESH) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
+ & ' below Coulomb threshold - event rejected',/)
+ ISTHKK(1) = 1
+ RETURN
+ ENDIF
+* negatively charged hadron - increase energy by Coulomb energy
+ ELSEIF (IICH(IJPROJ).EQ.-1) THEN
+ EPNI = EPNI+ETACOU(2)
+ ENDIF
+ IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
+* Effective target potential
+*sr 6.6. binding energy only (to avoid negative exc. energies)
+C EPNI = EPNI+EPOT(2,IJPROJ)
+ EBIPOT = EBINDP(2)
+ IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
+ & EBIPOT = EBINDN(2)
+ EPNI = EPNI+ABS(EBIPOT)
+* re-initialization of DTLTRA
+ DUM1 = ZERO
+ DUM2 = ZERO
+ CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
+ ENDIF
+ ENDIF
+
+* projectile in n-n cms
+ IF ((IP.LE.1).AND.(IT.GT.1)) THEN
+ PMASS1 = AAM(IJPROJ)
+C* VDM assumption
+C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
+ IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
+ PMASS2 = AAM(1)
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
+ PINIPR(5) = PMASS1
+ IF (PMASS1.GT.ZERO) THEN
+ PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
+ & *(PINIPR(4)+PINIPR(5)))
+ ELSE
+ PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
+ ENDIF
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
+ PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
+
+ CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
+ ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
+ PMASS1 = AAM(1)
+ PMASS2 = AAM(IJTARG)
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
+ PINITA(5) = PMASS2
+ PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
+ & *(PINITA(4)+PINITA(5)))
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+
+C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
+ PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
+
+ CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
+ ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+
+C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
+ PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
+
+ CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
+ PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
+
+ CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
+ ENDIF
+
+ RETURN
+
+*------- treatment of final state
+ 2 CONTINUE
+
+ NLOOP = NLOOP+1
+ IF (NLOOP.GT.1) SCPOT = 0.10D0
+C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
+
+ JPW = NPW
+ JPCW = NPCW
+ JTW = NTW
+ JTCW = NTCW
+ DO 40 K=1,4
+ PFSP(K) = ZERO
+ 40 CONTINUE
+
+ NOB = 0
+ NOM = 0
+ DO 900 I=NPOINT(4),NHKK
+ IDXOTH(I) = -1
+ IF (ISTHKK(I).EQ.1) THEN
+ IF (IDBAM(I).EQ.7) GOTO 900
+ IPOT = 0
+ IOTHER = 0
+* particle moving into forward direction
+ IF (PHKK(3,I).GE.ZERO) THEN
+* most likely to be effected by projectile potential
+ IPOT = 1
+* there is no projectile nucleus, try target
+ IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
+ IPOT = 2
+ IF (IP.GT.1) IOTHER = 1
+* there is no target nucleus --> skip
+ IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
+ ENDIF
+* particle moving into backward direction
+ ELSE
+* most likely to be effected by target potential
+ IPOT = 2
+* there is no target nucleus, try projectile
+ IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
+ IPOT = 1
+ IF (IT.GT.1) IOTHER = 1
+* there is no projectile nucleus --> skip
+ IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
+ ENDIF
+ ENDIF
+ IFLG = -IPOT
+* nobam=3: particle is in overlap-region or neither inside proj. nor target
+* =1: particle is not in overlap-region AND is inside target (2)
+* =2: particle is not in overlap-region AND is inside projectile (1)
+* flag particles which are inside the nucleus ipot but not in its
+* overlap region
+ IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
+ IF (IDBAM(I).NE.0) THEN
+* baryons: keep all nucleons and all others where flag is set
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
+ & THEN
+ NOB = NOB+1
+ PMOMB(NOB) = PHKK(3,I)
+ IDXB(NOB) = SIGN(10000000*IABS(IFLG)
+ & +1000000*IOTHER+I,IFLG)
+ ENDIF
+* mesons: keep only those mesons where flag is set
+ ELSE
+ IF (IFLG.GT.0) THEN
+ NOM = NOM+1
+ PMOMM(NOM) = PHKK(3,I)
+ IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ 900 CONTINUE
+*
+* sort particles in the arrays according to increasing long. momentum
+ CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
+ CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
+*
+* shuffle indices into one and the same array according to the later
+* sequence of correction
+ NCOR = 0
+ IF (IT.GT.1) THEN
+ DO 910 I=1,NOB
+ IF (PMOMB(I).GT.ZERO) GOTO 911
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 910 CONTINUE
+ 911 CONTINUE
+ IF (IP.GT.1) THEN
+ DO 912 J=1,NOB
+ I = NOB+1-J
+ IF (PMOMB(I).LT.ZERO) GOTO 913
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 912 CONTINUE
+ 913 CONTINUE
+ ELSE
+ DO 914 I=1,NOB
+ IF (PMOMB(I).GT.ZERO) THEN
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ ENDIF
+ 914 CONTINUE
+ ENDIF
+ ELSE
+ DO 915 J=1,NOB
+ I = NOB+1-J
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 915 CONTINUE
+ ENDIF
+ DO 925 I=1,NOM
+ IF (PMOMM(I).GT.ZERO) GOTO 926
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXM(I)
+ 925 CONTINUE
+ 926 CONTINUE
+ DO 927 J=1,NOM
+ I = NOM+1-J
+ IF (PMOMM(I).LT.ZERO) GOTO 928
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXM(I)
+ 927 CONTINUE
+ 928 CONTINUE
+*
+C IF (NEVHKK.EQ.484) THEN
+C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
+C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
+C WRITE(LOUT,9001) NOB,NOM,NCOR
+C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
+C WRITE(LOUT,'(/,A)') ' baryons '
+C DO 950 I=1,NOB
+CC J = IABS(IDXB(I))
+CC INDEX = J-IABS(J/10000000)*10000000
+C IPOT = IABS(IDXB(I))/10000000
+C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
+C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
+C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
+C 950 CONTINUE
+C WRITE(LOUT,'(/,A)') ' mesons '
+C DO 951 I=1,NOM
+CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
+C IPOT = IABS(IDXM(I))/10000000
+C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
+C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
+C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
+C 951 CONTINUE
+C 9002 FORMAT(1X,4I14,E14.5)
+C WRITE(LOUT,'(/,A)') ' all '
+C DO 952 I=1,NCOR
+CC J = IABS(IDXCOR(I))
+CC INDEX = J-IABS(J/10000000)*10000000
+CC IPOT = IABS(IDXCOR(I))/10000000
+C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
+C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
+C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
+C 952 CONTINUE
+C 9003 FORMAT(1X,4I14)
+C ENDIF
+*
+ DO 20 ICOR=1,NCOR
+ IPOT = IABS(IDXCOR(ICOR))/10000000
+ IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
+ I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
+ IDXOTH(I) = 1
+
+ IDSEC = IDBAM(I)
+
+* reduction of particle momentum by corresponding nuclear potential
+* (this applies only if Fermi-momenta are requested)
+
+ IF (LFERMI) THEN
+
+* Lorentz-transformation into the rest system of the selected nucleus
+ IMODE = -IPOT-1
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
+ PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
+ AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
+ JPMOD = 0
+
+ CHKLEV = TINY3
+ IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
+ IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
+ IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
+ 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
+ & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
+ & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
+ GOTO 23
+ ENDIF
+
+ DO 21 K=1,4
+ PSEC0(K) = PSEC(K)
+ 21 CONTINUE
+
+* the correction for nuclear potential effects is applied to as many
+* p/n as many nucleons were wounded; the momenta of other final state
+* particles are corrected only if they materialize inside the corresp.
+* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
+* = 3 part. outside proj. and targ., >=10 in overlapping region)
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
+ IF (IPOT.EQ.1) THEN
+ IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
+* this is most likely a wounded nucleon
+**test
+C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
+C & +(VHKK(2,IPW(JPW))/FM2MM)**2
+C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
+C RAD = RNUCLE*DBLE(IP)**ONETHI
+C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
+C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
+**
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPW = JPW-1
+ JPMOD = 1
+ ELSE
+* correct only if part. was materialized inside nucleus
+* and if it is ouside the overlapping region
+ IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+ ELSEIF (IPOT.EQ.2) THEN
+ IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
+* this is most likely a wounded nucleon
+**test
+C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
+C & +(VHKK(2,ITW(JTW))/FM2MM)**2
+C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
+C RAD = RNUCLE*DBLE(IT)**ONETHI
+C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
+C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
+**
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JTW = JTW-1
+ JPMOD = 1
+ ELSE
+* correct only if part. was materialized inside nucleus
+ IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+
+ IF (NLOOP.EQ.1) THEN
+* Coulomb energy correction:
+* the treatment of Coulomb potential correction is similar to the
+* one for nuclear potential
+ IF (IDSEC.EQ.1) THEN
+ IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
+ JPCW = JPCW-1
+ ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
+ JTCW = JTCW-1
+ ELSE
+ IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
+ ENDIF
+ ELSE
+ IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
+ ENDIF
+ IF (IICH(IDSEC).EQ.1) THEN
+* pos. particles: check if they are able to escape Coulomb potential
+ IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
+ ISTHKK(I) = 14+IPOT
+ IF (ISTHKK(I).EQ.15) THEN
+ DO 26 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)
+ 26 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
+ IF (IDSEC.EQ.1) NPCW = NPCW-1
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ DO 27 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)
+ 27 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
+ IF (IDSEC.EQ.1) NTCW = NTCW-1
+ ENDIF
+ GOTO 20
+ ENDIF
+ ELSEIF (IICH(IDSEC).EQ.-1) THEN
+* neg. particles: decrease energy by Coulomb-potential
+ PSEC(4) = PSEC(4)-ETACOU(IPOT)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+
+ 25 CONTINUE
+
+ IF (PSEC(4).LT.AMSEC) THEN
+ IF (IOULEV(6).GT.0)
+ & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
+ 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
+ & ' is not allowed to escape nucleus',/,
+ & 8X,'id : ',I3,' reduced energy: ',E15.4,
+ & ' mass: ',E12.3)
+ ISTHKK(I) = 14+IPOT
+ IF (ISTHKK(I).EQ.15) THEN
+ DO 28 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)
+ 28 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
+ IF (IDSEC.EQ.1) NPCW = NPCW-1
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ DO 29 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)
+ 29 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
+ IF (IDSEC.EQ.1) NTCW = NTCW-1
+ ENDIF
+ GOTO 20
+ ENDIF
+
+ IF (JPMOD.EQ.1) THEN
+ PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
+* 4-momentum after correction for nuclear potential
+ DO 22 K=1,3
+ PSEC(K) = PSEC(K)*PSECN/PSECO
+ 22 CONTINUE
+
+* store recoil momentum from particles escaping the nuclear potentials
+ DO 30 K=1,4
+ IF (IPOT.EQ.1) THEN
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
+ ELSEIF (IPOT.EQ.2) THEN
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
+ ENDIF
+ 30 CONTINUE
+
+* transform momentum back into n-n cms
+ IMODE = IPOT+1
+ CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & IDSEC,IMODE)
+ ENDIF
+
+ ENDIF
+
+ 23 CONTINUE
+ DO 31 K=1,4
+ PFSP(K) = PFSP(K)+PHKK(K,I)
+ 31 CONTINUE
+
+ 20 CONTINUE
+
+ DO 33 I=NPOINT(4),NHKK
+ IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
+ PFSP(1) = PFSP(1)+PHKK(1,I)
+ PFSP(2) = PFSP(2)+PHKK(2,I)
+ PFSP(3) = PFSP(3)+PHKK(3,I)
+ PFSP(4) = PFSP(4)+PHKK(4,I)
+ ENDIF
+ 33 CONTINUE
+
+ DO 34 K=1,5
+ PRCLPR(K) = TRCLPR(K)
+ PRCLTA(K) = TRCLTA(K)
+ 34 CONTINUE
+
+ IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
+* hadron-nucleus interactions: get residual momentum from energy-
+* momentum conservation
+ DO 32 K=1,4
+ PRCLPR(K) = ZERO
+ PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
+ 32 CONTINUE
+ ELSE
+* nucleus-hadron, nucleus-nucleus: get residual momentum from
+* accumulated recoil momenta of particles leaving the spectators
+* transform accumulated recoil momenta of residual nuclei into
+* n-n cms
+ PZI = PRCLPR(3)
+ PEI = PRCLPR(4)
+ CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
+ PZI = PRCLTA(3)
+ PEI = PRCLTA(4)
+ CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
+C IF (IP.GT.1) THEN
+ PRCLPR(3) = PRCLPR(3)+PINIPR(3)
+ PRCLPR(4) = PRCLPR(4)+PINIPR(4)
+C ENDIF
+ IF (IT.GT.1) THEN
+ PRCLTA(3) = PRCLTA(3)+PINITA(3)
+ PRCLTA(4) = PRCLTA(4)+PINITA(4)
+ ENDIF
+ ENDIF
+
+* check momenta of residual nuclei
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
+ & 1,IDUM,IDUM)
+ CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
+**sr 19.12. changed to avoid output when used with phojet
+C CHKLEV = TINY3
+ CHKLEV = TINY1
+ CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
+C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
+C & CALL DT_EVTOUT(4)
+ IF (IREJ1.GT.0) RETURN
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SCN4BA.FOR
+*COPY DT_SCN4BA
+*
+*===scn4ba=============================================================*
+*
+ SUBROUTINE DT_SCN4BA
+
+************************************************************************
+* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
+* This version dated 12.12.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
+ & TINY10=1.0D-10)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* treatment of residual nuclei: wounded nucleons
+ COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
+
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+
+ DIMENSION PLAB(2,5),PCMS(4)
+
+ IREJ = 0
+
+* get number of wounded nucleons
+ NPW = 0
+ NPW0 = 0
+ NPCW = 0
+ NPSTCK = 0
+ NTW = 0
+ NTW0 = 0
+ NTCW = 0
+ NTSTCK = 0
+
+ ISGLPR = 0
+ ISGLTA = 0
+ LRCLPR = .FALSE.
+ LRCLTA = .FALSE.
+
+C DO 2 I=1,NHKK
+ DO 2 I=1,NPOINT(1)
+* projectile nucleons wounded in primary interaction and in fzc
+ IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
+ NPW = NPW+1
+ IPW(NPW) = I
+ NPSTCK = NPSTCK+1
+ IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
+ IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
+C IF (IP.GT.1) THEN
+ DO 5 K=1,4
+ TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
+ 5 CONTINUE
+C ENDIF
+* target nucleons wounded in primary interaction and in fzc
+ ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
+ NTW = NTW+1
+ ITW(NTW) = I
+ NTSTCK = NTSTCK+1
+ IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
+ IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
+ IF (IT.GT.1) THEN
+ DO 6 K=1,4
+ TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
+ 6 CONTINUE
+ ENDIF
+ ELSEIF (ISTHKK(I).EQ.13) THEN
+ ISGLPR = I
+ ELSEIF (ISTHKK(I).EQ.14) THEN
+ ISGLTA = I
+ ENDIF
+ 2 CONTINUE
+
+ DO 11 I=NPOINT(4),NHKK
+* baryons which are unable to escape the nuclear potential of proj.
+ IF (ISTHKK(I).EQ.15) THEN
+ ISGLPR = I
+ NPSTCK = NPSTCK-1
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ NPW = NPW-1
+ IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
+ ENDIF
+ DO 7 K=1,4
+ TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
+ 7 CONTINUE
+* baryons which are unable to escape the nuclear potential of targ.
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ ISGLTA = I
+ NTSTCK = NTSTCK-1
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ NTW = NTW-1
+ IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
+ ENDIF
+ DO 8 K=1,4
+ TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
+ 8 CONTINUE
+ ENDIF
+ 11 CONTINUE
+
+* residual nuclei so far
+ IRESP = IP-NPSTCK
+ IREST = IT-NTSTCK
+
+* ckeck for "residual nuclei" consisting of one nucleon only
+* treat it as final state particle
+ IF (IRESP.EQ.1) THEN
+ ID = IDBAM(ISGLPR)
+ IST = ISTHKK(ISGLPR)
+ CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
+ & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
+ IF (IST.EQ.13) THEN
+ ISTHKK(ISGLPR) = 11
+ ELSE
+ ISTHKK(ISGLPR) = 2
+ ENDIF
+ CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
+ & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
+ NOBAM(NHKK) = NOBAM(ISGLPR)
+ JDAHKK(1,ISGLPR) = NHKK
+ DO 21 K=1,4
+ TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
+ 21 CONTINUE
+ ENDIF
+ IF (IREST.EQ.1) THEN
+ ID = IDBAM(ISGLTA)
+ IST = ISTHKK(ISGLTA)
+ CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
+ & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
+ IF (IST.EQ.14) THEN
+ ISTHKK(ISGLTA) = 12
+ ELSE
+ ISTHKK(ISGLTA) = 2
+ ENDIF
+ CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
+ & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
+ NOBAM(NHKK) = NOBAM(ISGLTA)
+ JDAHKK(1,ISGLTA) = NHKK
+ DO 22 K=1,4
+ TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
+ 22 CONTINUE
+ ENDIF
+
+* get nuclear potential corresp. to the residual nucleus
+ IPRCL = IP -NPW
+ IPZRCL = IPZ-NPCW
+ ITRCL = IT -NTW
+ ITZRCL = ITZ-NTCW
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
+
+* baryons unable to escape the nuclear potential are treated as
+* excited nucleons (ISTHKK=15,16)
+ DO 3 I=NPOINT(4),NHKK
+ IF (ISTHKK(I).EQ.1) THEN
+ ID = IDBAM(I)
+ IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
+* final state n and p not being outside of both nuclei are considered
+ NPOTP = 1
+ NPOTT = 1
+ IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
+ & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
+* Lorentz-trsf. into proj. rest sys. for those being inside proj.
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
+ & PLAB(1,4),ID,-2)
+ PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
+ PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
+ & (PLAB(1,4)+PLABT) ))
+ EKIN = PLAB(1,4)-PLAB(1,5)
+ IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
+ IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
+ ENDIF
+ IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
+ & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
+* Lorentz-trsf. into targ. rest sys. for those being inside targ.
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
+ & PLAB(2,4),ID,-3)
+ PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
+ PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
+ & (PLAB(2,4)+PLABT) ))
+ EKIN = PLAB(2,4)-PLAB(2,5)
+ IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
+ IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
+ ENDIF
+ IF (PHKK(3,I).GE.ZERO) THEN
+ ISTHKK(I) = NPOTT
+ IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
+ ELSE
+ ISTHKK(I) = NPOTP
+ IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
+ ENDIF
+ IF (ISTHKK(I).NE.1) THEN
+ J = ISTHKK(I)-14
+ DO 4 K=1,5
+ PHKK(K,I) = PLAB(J,K)
+ 4 CONTINUE
+ IF (ISTHKK(I).EQ.15) THEN
+ NPW = NPW-1
+ IF (ID.EQ.1) NPCW = NPCW-1
+ DO 9 K=1,4
+ TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
+ 9 CONTINUE
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ NTW = NTW-1
+ IF (ID.EQ.1) NTCW = NTCW-1
+ DO 10 K=1,4
+ TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
+ 10 CONTINUE
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+
+* again: get nuclear potential corresp. to the residual nucleus
+ IPRCL = IP -NPW
+ IPZRCL = IPZ-NPCW
+ ITRCL = IT -NTW
+ ITZRCL = ITZ-NTCW
+c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
+cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
+c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
+C AFERP = 0.0D0
+c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
+cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
+c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
+C AFERT = 0.0D0
+C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
+C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
+C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
+C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
+ AFERP = FERMOD+0.1D0
+ AFERT = FERMOD+0.1D0
+
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
+
+ RETURN
+ END
+
+*$ CREATE DT_FICONF.FOR
+*COPY DT_FICONF
+*
+*===ficonf=============================================================*
+*
+ SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
+
+************************************************************************
+* Treatment of FInal CONFiguration including evaporation, fission and *
+* Fermi-break-up (for light nuclei only). *
+* Adopted from the original routine FINALE and extended to residual *
+* projectile nuclei. *
+* This version dated 12.12.95 is written by S. Roesler. *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
+ PARAMETER (ANGLGB=5.0D-16)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+
+* treatment of residual nuclei: properties of residual nuclei
+ COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
+ & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
+ & NTOTFI(2),NPROFI(2)
+
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* INCLUDE '(DIMPAR)'
+* DIMPAR taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(GENSTK)'
+* GENSTK taken from FLUKA
+ COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
+ & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
+ & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
+ & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
+ & TVRECL, TVHEAV, TVBIND,
+ & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
+
+* INCLUDE '(RESNUC)'
+* RESNUC from FLUKA
+ LOGICAL LRNFSS, LFRAGM
+ COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
+ & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
+ & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
+ & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
+ & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
+ & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
+ & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
+ & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
+ & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
+ & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
+ & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
+ & LRNFSS, LFRAGM
+
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMPRTN = 0.93827231 D+00 )
+ PARAMETER ( AMNTRN = 0.93956563 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( ELCCGS = 4.8032068 D-10 )
+ PARAMETER ( ELCMKS = 1.60217733 D-19 )
+ PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
+ & * 1.D-09 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( FERTHO = 14.33 D-09 )
+ PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
+ PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
+ PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
+
+* INCLUDE '(NUCDAT)'
+* Taken from FLUKA
+ PARAMETER ( AMUAMU = AMUGEV )
+ PARAMETER ( AMPROT = AMPRTN )
+ PARAMETER ( AMNEUT = AMNTRN )
+ PARAMETER ( AMELEC = AMELCT )
+ PARAMETER ( R0NUCL = 1.12 D+00 )
+ PARAMETER ( RCCOUL = 1.7 D+00 )
+ PARAMETER ( COULPR = COUGFM )
+ PARAMETER ( AMHYDR = AMPRTN + AMELCT )
+ PARAMETER ( AMHTON = AMHYDR - AMNTRN )
+ PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
+ PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
+ PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
+* Gammin : threshold for deexcitation gammas production, set to 1 keV
+* (this means that up to 1 keV of energy unbalancing can occur
+* during an event)
+ PARAMETER ( GAMMIN = 1.0D-06 )
+ PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
+* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
+ PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
+*
+ COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
+ & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
+ & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
+ & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
+ & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
+ & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
+ & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
+ & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
+ & ELBNDE (0:110)
+
+* INCLUDE '(PAREVT)'
+* Taken from FLUKA
+ PARAMETER ( FRDIFF = 0.2D+00 )
+ PARAMETER ( ETHSEA = 1.0D+00 )
+*
+ LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+ & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
+ & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
+ & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
+ COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
+ & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+ & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+ & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
+ & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
+ & LVP2XX, LV2XNW, LNWV2X, LEVFIN
+
+* INCLUDE '(FHEAVY)'
+* Taken from FLUKA
+ PARAMETER ( MXHEAV = 100 )
+ PARAMETER ( KXHEAV = 30 )
+ CHARACTER*8 ANHEAV
+ COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
+ & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
+ & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
+ & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
+ & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
+ & KHEAVY (MXHEAV), INFHEA (MXHEAV),
+ & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
+ & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
+ & KHHEAV (IHYPMX,KXHEAV), NPHEAV
+ COMMON / FHEAVC / ANHEAV (KXHEAV)
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
+ & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
+ & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
+
+ DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
+ LOGICAL LLCPOT
+ DATA EXC,NEXC /520*ZERO,520*0/
+ DATA EXPNUC /4.0D-3,4.0D-3/
+
+ IREJ = 0
+ LRCLPR = .FALSE.
+ LRCLTA = .FALSE.
+
+* skip residual nucleus treatment if not requested or in case
+* of central collisions
+ IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
+
+ DO 1 K=1,2
+ IDPAR(K) = 0
+ IDXPAR(K)= 0
+ NTOT(K) = 0
+ NTOTFI(K)= 0
+ NPRO(K) = 0
+ NPROFI(K)= 0
+ NN(K) = 0
+ NH(K) = 0
+ NHPOS(K) = 0
+ NQ(K) = 0
+ EEXC(K) = ZERO
+ MO1(K) = 0
+ MO2(K) = 0
+ DO 2 I=1,4
+ VRCL(K,I) = ZERO
+ WRCL(K,I) = ZERO
+ 2 CONTINUE
+ 1 CONTINUE
+ NFSP = 0
+ INUC(1) = IP
+ INUC(2) = IT
+
+ DO 3 I=1,NHKK
+
+* number of final state particles
+ IF (ABS(ISTHKK(I)).EQ.1) THEN
+ NFSP = NFSP+1
+ IDFSP = IDBAM(I)
+ ENDIF
+
+* properties of remaining nucleon configurations
+ KF = 0
+ IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
+ IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
+ IF (KF.GT.0) THEN
+ IF (MO1(KF).EQ.0) MO1(KF) = I
+ MO2(KF) = I
+* position of residual nucleus = average position of nucleons
+ DO 4 K=1,4
+ VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
+ WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
+ 4 CONTINUE
+* total number of particles contributing to each residual nucleus
+ NTOT(KF) = NTOT(KF)+1
+ IDTMP = IDBAM(I)
+ IDXTMP = I
+* total charge of residual nuclei
+ NQ(KF) = NQ(KF)+IICH(IDTMP)
+* number of protons
+ IF (IDHKK(I).EQ.2212) THEN
+ NPRO(KF) = NPRO(KF)+1
+* number of neutrons
+ ELSEIF (IDHKK(I).EQ.2112) THEN
+ NN(KF) = NN(KF)+1
+ ELSE
+* number of baryons other than n, p
+ IF (IIBAR(IDTMP).EQ.1) THEN
+ NH(KF) = NH(KF)+1
+ IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
+ ELSE
+* any other mesons (status set to 1)
+C WRITE(LOUT,1002) KF,IDTMP
+C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
+C & ' containing meson ',I4,', status set to 1')
+ ISTHKK(I) = 1
+ IDTMP = IDPAR(KF)
+ IDXTMP = IDXPAR(KF)
+ NTOT(KF) = NTOT(KF)-1
+ ENDIF
+ ENDIF
+ IDPAR(KF) = IDTMP
+ IDXPAR(KF) = IDXTMP
+ ENDIF
+ 3 CONTINUE
+
+* reject elastic events (def: one final state particle = projectile)
+ IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
+ IREXCI(3) = IREXCI(3)+1
+ GOTO 9999
+C RETURN
+ ENDIF
+
+* check if one nucleus disappeared..
+C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
+C DO 5 K=1,4
+C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
+C PRCLPR(K) = ZERO
+C 5 CONTINUE
+C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
+C DO 6 K=1,4
+C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
+C PRCLTA(K) = ZERO
+C 6 CONTINUE
+C ENDIF
+
+ ICOR = 0
+ INORCL = 0
+ DO 7 I=1,2
+ DO 8 K=1,4
+* get the average of the nucleon positions
+ VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
+ WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
+ IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
+ IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
+ 8 CONTINUE
+* mass number and charge of residual nuclei
+ AIF(I) = DBLE(NTOT(I))
+ AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
+ IF (NTOT(I).GT.1) THEN
+* masses of residual nuclei in ground state
+
+C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
+ AMRCL0(I) = AIF(I)*AMUC12
+ & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
+
+* masses of residual nuclei
+ PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
+ AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
+ IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
+*
+* M_res^2 < 0 : configuration not allowed
+*
+* a) re-calculate E_exc with scaled nuclear potential
+* (conditional jump to label 9998)
+* b) or reject event if N_loop(max) is exceeded
+* (conditional jump to label 9999)
+*
+ IF (AMRCL(I).LE.ZERO) THEN
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
+ & PRCL(I,4),NTOT
+ 1000 FORMAT(1X,'warning! negative excitation energy',/,
+ & I4,4E15.4,2I4)
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(2) = IREXCI(2)+1
+ GOTO 9999
+ ENDIF
+*
+* 0 < M_res < M_res0 : mass below ground-state mass
+*
+* a) we had residual nuclei with mass N_tot and reasonable E_exc
+* before- assign average E_exc of those configurations to this
+* one ( Nexc(i,N_tot) > 0 )
+* b) or (and this applies always if run in transport codes) go up
+* one mass number and
+* i) if mass now larger than proj/targ mass or if run in
+* transport codes assign average E_exc per wounded nucleon
+* x number of wounded nucleons (Inuc-Ntot)
+* ii) or assign average E_exc of those configurations to this
+* one ( Nexc(i,m) > 0 )
+*
+ ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
+ & THEN
+ M = MIN(NTOT(I),260)
+ IF (NEXC(I,M).GT.0) THEN
+ AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
+ ELSE
+ 70 CONTINUE
+ M = M+1
+**sr corrected 27.12.06
+* IF (M.GE.INUC(I)) THEN
+* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
+ IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
+ IF ( INUC (I) .GT. NTOT (I) ) THEN
+ AMRCL(I) = AMRCL0(I)
+ & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
+ ELSE
+ AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
+ END IF
+**
+ ELSE
+ IF (NEXC(I,M).GT.0) THEN
+ AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
+ ELSE
+ GOTO 70
+ ENDIF
+ ENDIF
+ ENDIF
+ EEXC(I) = AMRCL(I)-AMRCL0(I)
+ ICOR = ICOR+I
+*
+* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
+*
+* a) re-calculate E_exc with scaled nuclear potential
+* (conditional jump to label 9998)
+* b) or reject event if N_loop(max) is exceeded
+* (conditional jump to label 9999)
+*
+*
+ ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
+ 1004 FORMAT(1X,'warning! too high excitation energy',/,
+ & I4,1P,2E15.4,3I5)
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(2) = IREXCI(2)+1
+ GOTO 9999
+ ENDIF
+*
+* Otherwise (reasonable E_exc) :
+* E_exc = M_res - M_res0
+* in addition: calculate and save E_exc per wounded nucleon as
+* well as E_exc in <E_exc> counter
+*
+ ELSE
+* excitation energies of residual nuclei
+ EEXC(I) = AMRCL(I)-AMRCL0(I)
+**sr 27.12.06 new excitation energy correction by A.F.
+*
+* all parts with Ilcopt<3 commented since not used
+*
+* still to be done/decided:
+* Increase Icor and put back both residual nuclei on mass shell
+* with the exciting correction further below.
+* For the moment the modification in the excitation energy is simply
+* corrected by scaling the energy of the residual nucleus.
+*
+ LLCPOT = .TRUE.
+ ILCOPT = 3
+ IF ( LLCPOT ) THEN
+ NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
+ IF ( ILCOPT .LE. 2 ) THEN
+C* Patch for Fermi momentum reduction correlated with impact parameter:
+C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
+C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
+C AKPRHO = ONE - DLKPRH
+C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
+C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
+C & 0.05D+00 )
+C* REDORI = 0.75D+00
+C* REDORI = ONE
+C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
+ ELSE
+ DLKPRH = ZERO
+ RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
+* Take out roughly one/half of the skin:
+ RDCORE = RDCORE - 0.5D+00
+ FRCFLL = RDCORE**3
+ PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
+ PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
+ FRCFLL = ONE - PRSKIN
+ FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
+ REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
+ END IF
+ IF ( NNCHIT .GT. 0 ) THEN
+C IF ( ILCOPT .EQ. 1 ) THEN
+C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
+C DO 1220 NCH = 1, 10
+C ETAETA = ( ONE - SKINRH**INUC(I)
+C & - DBLE(INUC(I))* ( ONE - FRCFLL )
+C & * ( ONE - SKINRH ) )
+C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
+C & * ( ONE - FRCFLL) * SKINRH )
+C SKINRH = SKINRH * ( ONE + ETAETA )
+C 1220 CONTINUE
+C PRSKIN = SKINRH**(NNCHIT-1)
+C ELSE IF ( ILCOPT .EQ. 2 ) THEN
+C PRSKIN = ONE - FRCFLL
+C END IF
+ REDCTN = ZERO
+ DO 1230 NCH = 1, NNCHIT
+ IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
+ PRFRMI = (( ONE - 2.D+00 * DLKPRH )
+ & * DT_RNDM(PRFRMI))**0.333333333333D+00
+ ELSE
+ PRFRMI = ( ONE - 2.D+00 * DLKPRH
+ & * DT_RNDM(PRFRMI))**0.333333333333D+00
+ END IF
+ REDCTN = REDCTN + PRFRMI**2
+ 1230 CONTINUE
+ REDCTN = REDCTN / DBLE (NNCHIT)
+ ELSE
+ REDCTN = 0.5D+00
+ END IF
+ EEXC (I) = EEXC (I) * REDCTN / REDORI
+ AMRCL (I) = AMRCL0 (I) + EEXC (I)
+ PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
+ END IF
+**
+ IF (ICASCA.EQ.0) THEN
+ EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
+ M = MIN(NTOT(I),260)
+ EXC(I,M) = EXC(I,M)+EEXC(I)
+ NEXC(I,M) = NEXC(I,M)+1
+ ENDIF
+ ENDIF
+ ELSEIF (NTOT(I).EQ.1) THEN
+ WRITE(LOUT,1003) I
+ 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
+ GOTO 9999
+ ELSE
+ AMRCL0(I) = ZERO
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ INORCL = INORCL+I
+ ENDIF
+ 7 CONTINUE
+
+ PRCLPR(5) = AMRCL(1)
+ PRCLTA(5) = AMRCL(2)
+
+ IF (ICOR.GT.0) THEN
+ IF (INORCL.EQ.0) THEN
+* one or both residual nuclei consist of one nucleon only, transform
+* this nucleon on mass shell
+ DO 9 K=1,4
+ P1IN(K) = PRCL(1,K)
+ P2IN(K) = PRCL(2,K)
+ 9 CONTINUE
+ XM1 = AMRCL(1)
+ XM2 = AMRCL(2)
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,*) 'ficonf-mashel rejection'
+ GOTO 9999
+ ENDIF
+ DO 10 K=1,4
+ PRCL(1,K) = P1OUT(K)
+ PRCL(2,K) = P2OUT(K)
+ PRCLPR(K) = P1OUT(K)
+ PRCLTA(K) = P2OUT(K)
+ 10 CONTINUE
+ PRCLPR(5) = AMRCL(1)
+ PRCLTA(5) = AMRCL(2)
+ ELSE
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
+ & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
+ & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
+ & AMRCL(2),AMRCL(2)-AMRCL0(2)
+ 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
+ & ' correction',/,11X,'at event',I8,
+ & ', nucleon config. 1:',2I4,' 2:',2I4,
+ & 2(/,11X,3E12.3))
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(1) = IREXCI(1)+1
+ ENDIF
+ ENDIF
+ ENDIF
+
+* update counter
+C IF (NRESEV(1).NE.NEVHKK) THEN
+C NRESEV(1) = NEVHKK
+C NRESEV(2) = NRESEV(2)+1
+C ENDIF
+ NRESEV(2) = NRESEV(2)+1
+ DO 15 I=1,2
+ EXCDPM(I) = EXCDPM(I)+EEXC(I)
+ EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
+ NRESTO(I) = NRESTO(I)+NTOT(I)
+ NRESPR(I) = NRESPR(I)+NPRO(I)
+ NRESNU(I) = NRESNU(I)+NN(I)
+ NRESBA(I) = NRESBA(I)+NH(I)
+ NRESPB(I) = NRESPB(I)+NHPOS(I)
+ NRESCH(I) = NRESCH(I)+NQ(I)
+ 15 CONTINUE
+
+* evaporation
+ IF (LEVPRT) THEN
+ DO 13 I=1,2
+* initialize evaporation counter
+ EEXCFI(I) = ZERO
+ IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
+ & (EEXC(I).GT.ZERO)) THEN
+* put residual nuclei into DTEVT1
+ IDRCL = 80000
+ JMASS = INT( AIF(I))
+ JCHAR = INT(AIZF(I))
+* the following patch is required to transmit the correct excitation
+* energy to Eventd
+ IF (ITRSPT.EQ.1) THEN
+ IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
+ & (IOULEV(3).GT.0))
+ & WRITE(LOUT,*)
+ & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
+ & AMRCL(I),AMRCL0(I),EEXC(I)
+ PRCL0 = PRCL(I,4)
+ PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
+ & +PRCL(I,3)**2)
+ IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
+ WRITE(LOUT,*)
+ & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
+ ENDIF
+ ENDIF
+ CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
+ & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
+**sr 22.6.97
+ NOBAM(NHKK) = I
+**
+ DO 14 J=1,4
+ VHKK(J,NHKK) = VRCL(I,J)
+ WHKK(J,NHKK) = WRCL(I,J)
+ 14 CONTINUE
+* interface to evaporation module - fill final residual nucleus into
+* common FKRESN
+* fill resnuc only if code is not used as event generator in Fluka
+ IF (ITRSPT.NE.1) THEN
+ PXRES = PRCL(I,1)
+ PYRES = PRCL(I,2)
+ PZRES = PRCL(I,3)
+ IBRES = NPRO(I)+NN(I)+NH(I)
+ ICRES = NPRO(I)+NHPOS(I)
+ ANOW = DBLE(IBRES)
+ ZNOW = DBLE(ICRES)
+ PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
+* ground state mass of the residual nucleus (should be equal to AM0T)
+
+ AMNRES = AMRCL0(I)
+ AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
+
+* common FKFINU
+ TV = ZERO
+* kinetic energy of residual nucleus
+ TVRECL = PRCL(I,4)-AMRCL(I)
+* excitation energy of residual nucleus
+ TVCMS = EEXC(I)
+ PTOLD = PTRES
+ PTRES = SQRT(ABS(TVRECL*(TVRECL+
+ & 2.0D0*(AMMRES+TVCMS))))
+ IF (PTOLD.LT.ANGLGB) THEN
+ CALL DT_RACO(PXRES,PYRES,PZRES)
+ PTOLD = ONE
+ ENDIF
+ PXRES = PXRES*PTRES/PTOLD
+ PYRES = PYRES*PTRES/PTOLD
+ PZRES = PZRES*PTRES/PTOLD
+* zero counter of secondaries from evaporation
+ NP = 0
+* evaporation
+ WE = ONE
+
+ NPHEAV = 0
+ LRNFSS = .FALSE.
+ LFRAGM = .FALSE.
+ CALL EVEVAP(WE)
+
+* put evaporated particles and residual nuclei to DTEVT1
+ MO = NHKK
+ CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
+ ENDIF
+ EEXCFI(I) = EXCITF
+ EXCEVA(I) = EXCEVA(I)+EXCITF
+ ENDIF
+ 13 CONTINUE
+ ENDIF
+
+ RETURN
+
+C9998 IREXCI(1) = IREXCI(1)+1
+ 9998 IREJ = IREJ+1
+ 9999 CONTINUE
+ LRCLPR = .TRUE.
+ LRCLTA = .TRUE.
+ IREJ = IREJ+1
+ RETURN
+ END
+
+*$ CREATE DT_EVA2HE.FOR
+*COPY DT_EVA2HE
+* *
+*====eva2he============================================================*
+* *
+ SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
+
+************************************************************************
+* Interface between common's of evaporation module (FKFINU,FKFHVY) *
+* and DTEVT1. *
+* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
+* EEXCF exitation energy of residual nucleus after evaporation *
+* IRCL = 1 projectile residual nucleus *
+* = 2 target residual nucleus *
+* This version dated 19.04.95 is written by S. Roesler. *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* Note: DTEVT2 - special use for heavy fragments !
+* (IDRES(I) = mass number, IDXRES(I) = charge)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+
+* treatment of residual nuclei: properties of residual nuclei
+ COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
+ & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
+ & NTOTFI(2),NPROFI(2)
+
+* INCLUDE '(DIMPAR)'
+* Taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(GENSTK)'
+* Taken from FLUKA
+ PARAMETER ( MXP = MXPSCS )
+*
+ COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
+ & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
+ & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
+ & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
+ & TVRECL, TVHEAV, TVBIND,
+ & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
+
+* INCLUDE '(RESNUC)'
+ LOGICAL LRNFSS, LFRAGM
+ COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
+ & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
+ & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
+ & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
+ & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
+ & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
+ & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
+ & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
+ & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
+ & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
+ & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
+ & LRNFSS, LFRAGM
+* Taken from FLUKA
+
+* INCLUDE '(FHEAVY)'
+* Taken from FLUKA
+ PARAMETER ( MXHEAV = 100 )
+ PARAMETER ( KXHEAV = 30 )
+ CHARACTER*8 ANHEAV
+ COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
+ & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
+ & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
+ & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
+ & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
+ & KHEAVY (MXHEAV), INFHEA (MXHEAV),
+ & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
+ & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
+ & KHHEAV (IHYPMX,KXHEAV), NPHEAV
+ COMMON / FHEAVC / ANHEAV (KXHEAV)
+
+ DIMENSION IPTOKP(39)
+ DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
+ & 100, 101, 97, 102, 98, 103, 109, 115 /
+
+ IREJ = 0
+
+* skip if evaporation package is not included
+ IF (.NOT.LEVAPO) RETURN
+
+* update counter
+ IF (NRESEV(3).NE.NEVHKK) THEN
+ NRESEV(3) = NEVHKK
+ NRESEV(4) = NRESEV(4)+1
+ ENDIF
+
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
+ & IDUM,IDUM)
+* mass number/charge of residual nucleus before evaporation
+ IBTOT = IDRES(MO)
+ IZTOT = IDXRES(MO)
+
+* protons/neutrons/gammas
+ DO 1 I=1,NP
+ PX = CXR(I)*PLR(I)
+ PY = CYR(I)*PLR(I)
+ PZ = CZR(I)*PLR(I)
+ ID = IPTOKP(KPART(I))
+ IDPDG = IDT_IPDGHA(ID)
+ AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
+ & (2.0D0*MAX(TKI(I),TINY10))
+ IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
+ WRITE(LOUT,1000) ID,AM,AAM(ID)
+ 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
+ & 'particle',I3,2E10.3)
+ ENDIF
+ PE = TKI(I)+AM
+ CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
+ NOBAM(NHKK) = IRCL
+ IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+ IBTOT = IBTOT-IIBAR(ID)
+ IZTOT = IZTOT-IICH(ID)
+ 1 CONTINUE
+
+* heavy fragments
+ DO 2 I=1,NPHEAV
+ PX = CXHEAV(I)*PHEAVY(I)
+ PY = CYHEAV(I)*PHEAVY(I)
+ PZ = CZHEAV(I)*PHEAVY(I)
+ IDHEAV = 80000
+ AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
+ & (2.0D0*MAX(TKHEAV(I),TINY10))
+ PE = TKHEAV(I)+AM
+ CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
+ & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
+ NOBAM(NHKK) = IRCL
+ IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+ IBTOT = IBTOT-IBHEAV(KHEAVY(I))
+ IZTOT = IZTOT-ICHEAV(KHEAVY(I))
+ 2 CONTINUE
+
+ IF (IBRES.GT.0) THEN
+* residual nucleus after evaporation
+ IDNUC = 80000
+ CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
+ & IBRES,ICRES,0)
+ NOBAM(NHKK) = IRCL
+ ENDIF
+ EEXCF = TVCMS
+ NTOTFI(IRCL) = IBRES
+ NPROFI(IRCL) = ICRES
+ IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
+ IBTOT = IBTOT-IBRES
+ IZTOT = IZTOT-ICRES
+
+* count events with fission
+ NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
+ IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
+
+* energy-momentum conservation check
+ IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
+C IF (IREJ.GT.0) THEN
+C CALL DT_EVTOUT(4)
+C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
+C ENDIF
+* baryon-number/charge conservation check
+ IF (IBTOT+IZTOT.NE.0) THEN
+ WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
+ 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
+ & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_EBIND.FOR
+*COPY DT_EBIND
+*
+*===ebind==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
+
+************************************************************************
+* Binding energy for nuclei. *
+* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
+* IA mass number *
+* IZ atomic number *
+* This version dated 5.5.95 is updated by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0)
+
+ DATA A1, A2, A3, A4, A5
+ & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
+
+ IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
+ WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
+ DT_EBIND = ZERO
+ RETURN
+ ENDIF
+ AA = IA
+ DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
+ & -A4*(IA-2*IZ)**2/AA
+ IF (MOD(IA,2).EQ.1) THEN
+ IA5 = 0
+ ELSEIF (MOD(IZ,2).EQ.1) THEN
+ IA5 = 1
+ ELSE
+ IA5 = -1
+ ENDIF
+ DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* DPMJET 3.0: cross section routines *
+* *
+************************************************************************
+*
+*
+* SUBROUTINE DT_SHNDIF
+* diffractive cross sections (all energies)
+* SUBROUTINE DT_PHOXS
+* total and inel. cross sections from PHOJET interpol. tables
+* SUBROUTINE DT_XSHN
+* total and el. cross sections for all energies
+* SUBROUTINE DT_SIHNAB
+* pion 2-nucleon absorption cross sections
+* SUBROUTINE DT_SIGEMU
+* cross section for target "compounds"
+* SUBROUTINE DT_SIGGA
+* photon nucleus cross sections
+* SUBROUTINE DT_SIGGAT
+* photon nucleus cross sections from tables
+* SUBROUTINE DT_SANO
+* anomalous hard photon-nucleon cross sections from tables
+* SUBROUTINE DT_SIGGP
+* photon nucleon cross sections
+* SUBROUTINE DT_SIGVEL
+* quasi-elastic vector meson prod. cross sections
+* DOUBLE PRECISION FUNCTION DT_SIGVP
+* sigma_VN(tilde)
+* DOUBLE PRECISION FUNCTION DT_RRM2
+* DOUBLE PRECISION FUNCTION DT_RM2
+* DOUBLE PRECISION FUNCTION DT_SAM2
+* SUBROUTINE DT_CKMT
+* SUBROUTINE DT_CKMTX
+* SUBROUTINE DT_PDF0
+* SUBROUTINE DT_CKMTQ0
+* SUBROUTINE DT_CKMTDE
+* SUBROUTINE DT_CKMTPR
+* FUNCTION DT_CKMTFF
+*
+* SUBROUTINE DT_FLUINI
+* total nucleon cross section fluctuation treatment
+*
+* SUBROUTINE DT_SIGTBL
+* pre-tabulation of low-energy elastic x-sec. using SIHNEL
+* SUBROUTINE DT_XSTABL
+* service routines
+*
+*
+*$ CREATE DT_SHNDIF.FOR
+*COPY DT_SHNDIF
+*
+*===shndif===============================================================*
+*
+ SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
+
+**********************************************************************
+* Single diffractive hadron-nucleon cross sections *
+* S.Roesler 14/1/93 *
+* *
+* The cross sections are calculated from extrapolated single *
+* diffractive antiproton-proton cross sections (DTUJET92) using *
+* scaling relations between total and single diffractive cross *
+* sections. *
+**********************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+*
+ CSD1 = 4.201483727D0
+ CSD4 = -0.4763103556D-02
+ CSD5 = 0.4324148297D0
+*
+ CHMSD1 = 0.8519297242D0
+ CHMSD4 = -0.1443076599D-01
+ CHMSD5 = 0.4014954567D0
+*
+ EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
+ PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
+*
+ SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
+ SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
+ FRAC = SHMSD/SDIAPP
+*
+ GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
+ & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
+ & 10, 10, 20, 20, 20) KPROJ
+*
+ 10 CONTINUE
+*---------------------------- p - p , n - p , sigma0+- - p ,
+* Lambda - p
+ CSD1 = 6.004476070D0
+ CSD4 = -0.1257784606D-03
+ CSD5 = 0.2447335720D0
+ SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
+ SIGDIH = FRAC*SIGDIF
+ RETURN
+*
+ 20 CONTINUE
+*
+ KPSCAL = 2
+ KTSCAL = 1
+C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
+ DUMZER = ZERO
+ CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
+ F = SDIAPP/SIGTO
+ KT = 1
+C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
+ CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
+ SIGDIF = SIGTO*F
+ SIGDIH = FRAC*SIGDIF
+ RETURN
+*
+ 999 CONTINUE
+*-------------------------- leptons..
+ SIGDIF = 1.D-10
+ SIGDIH = 1.D-10
+ RETURN
+ END
+
+*$ CREATE DT_PHOXS.FOR
+*COPY DT_PHOXS
+*
+*===phoxs================================================================*
+*
+ SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
+
+************************************************************************
+* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
+* interpolation tables. *
+* This version dated 05.11.97 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+**PHOJET105a
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+
+ IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
+ WRITE(LOUT,*) MCGENE
+ 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
+ STOP
+ ENDIF
+
+ IF (ECM.LE.ZERO) THEN
+ EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
+ ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
+ ENDIF
+
+ IF (MODE.EQ.1) THEN
+* DL
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = ECM*ECM
+ STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
+ ALPHAP= 0.25D0
+ BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
+ SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
+ SINE = STOT-SIGEL
+ SDIF1 = ZERO
+ ELSE
+* Phojet
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 1 I=2,ISIMAX
+ IF (ECM.LE.SIGECM(IP,I)) GOTO 2
+ 1 CONTINUE
+ 2 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ IF (LFIRST) THEN
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'PHOXS: warning! energy above initialization limit (',
+ & ECM,SIGECM(IP,ISIMAX)
+ LFIRST = .FALSE.
+ ENDIF
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+ STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
+ & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
+ BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_XSHN.FOR
+*COPY DT_XSHN
+*
+*===xshn===============================================================*
+*
+ SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
+
+************************************************************************
+* Total and elastic hadron-nucleon cross section. *
+* Below 500GeV cross sections are based on the '98 data compilation *
+* of the PDG. At higher energies PHOJET results are used (patched to *
+* the low energy data at 500GeV). *
+* IP projectile index (BAMJET numbering scheme) *
+* (should be in the range 1..25) *
+* IT target index (BAMJET numbering scheme) *
+* (1 = proton, 8 = neutron) *
+* PL laboratory momentum *
+* ECM cm. energy (ignored if PL>0) *
+* STOT total cross section *
+* SELA elastic cross section *
+* Last change: 24.4.99 by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0)
+
+ PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
+ & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
+ PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
+
+ LOGICAL LFIRST
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+**PHOJET105a
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
+ DIMENSION IDXDAT(25,2)
+*
+ DATA APL /
+ &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
+ &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
+ &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
+ &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
+ & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
+ & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
+ & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
+*
+* total cross sections:
+* p p
+ DATA (ASIGTO(1,K),K=1,NPOINT) /
+ & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
+ & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
+ & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
+ & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
+ & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
+ & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
+ & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
+* pbar p
+ DATA (ASIGTO(2,K),K=1,NPOINT) /
+ & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
+ & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
+ & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
+ & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
+ & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
+ & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
+ & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
+* n p
+ DATA (ASIGTO(3,K),K=1,NPOINT) /
+ & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
+ & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
+ & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
+ & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
+ & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
+ & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
+ & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
+* pi+ p
+ DATA (ASIGTO(4,K),K=1,NPOINT) /
+ & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
+ & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
+ & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
+ & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
+ & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
+ & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
+ & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
+* pi- p
+ DATA (ASIGTO(5,K),K=1,NPOINT) /
+ & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
+ & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
+ & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
+ & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
+ & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
+ & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
+ & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
+* K+ p
+ DATA (ASIGTO(6,K),K=1,NPOINT) /
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
+ & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
+ & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
+ & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
+ & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
+* K- p
+ DATA (ASIGTO(7,K),K=1,NPOINT) /
+ & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
+ & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
+ & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
+ & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
+ & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
+ & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
+ & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
+* K+ n
+ DATA (ASIGTO(8,K),K=1,NPOINT) /
+ & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
+ & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
+ & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
+ & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
+ & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
+ & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
+ & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
+* K- n
+ DATA (ASIGTO(9,K),K=1,NPOINT) /
+ & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
+ & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
+ & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
+ & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
+ & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
+ & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
+ & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
+* Lambda p
+ DATA (ASIGTO(10,K),K=1,NPOINT) /
+ & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
+ & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
+ & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
+ & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
+ & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
+ & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
+ & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
+*
+* elastic cross sections:
+* p p
+ DATA (ASIGEL(1,K),K=1,NPOINT) /
+ & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
+ & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
+ & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
+ & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
+ & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
+ & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
+ & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
+* pbar p
+ DATA (ASIGEL(2,K),K=1,NPOINT) /
+ & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
+ & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
+ & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
+ & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
+ & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
+ & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
+ & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
+* n p
+ DATA (ASIGEL(3,K),K=1,NPOINT) /
+ & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
+ & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
+ & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
+ & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
+ & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
+ & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
+ & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
+* pi+ p
+ DATA (ASIGEL(4,K),K=1,NPOINT) /
+ & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
+ & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
+ & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
+ & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
+ & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
+ & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
+ & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
+* pi- p
+ DATA (ASIGEL(5,K),K=1,NPOINT) /
+ & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
+ & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
+ & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
+ & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
+ & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
+ & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
+ & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
+* K+ p
+ DATA (ASIGEL(6,K),K=1,NPOINT) /
+ & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
+ & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
+ & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
+ & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
+ & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
+ & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
+ & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
+* K- p
+ DATA (ASIGEL(7,K),K=1,NPOINT) /
+ & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
+ & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
+ & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
+ & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
+ & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
+ & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
+ & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
+* K+ n
+ DATA (ASIGEL(8,K),K=1,NPOINT) /
+ & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
+ & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
+ & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
+ & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
+ & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
+ & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
+ & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
+* K- n
+ DATA (ASIGEL(9,K),K=1,NPOINT) /
+ & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
+ & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
+ & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
+ & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
+ & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
+ & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
+ & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
+* Lambda p
+ DATA (ASIGEL(10,K),K=1,NPOINT) /
+ & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
+ & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
+ & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
+ & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
+ & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
+ & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
+ & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
+
+ DATA (IDXDAT(K,1),K=1,25) /
+ & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
+ & 1, 3,45, 8, 9/
+ DATA (IDXDAT(K,2),K=1,25) /
+ & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
+ & 3, 1,45, 6, 7/
+
+ DATA LFIRST /.TRUE./
+
+ IF (LFIRST) THEN
+ APLABL = LOG10(PLABLO)
+ APLABH = LOG10(PLABHI)
+ APTHRE = LOG10(PTHRE)
+ ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
+ ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
+ DUM0 = ZERO
+ PHOPLA = PLABHI
+ PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
+ ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
+ IF (MCGENE.EQ.2) THEN
+ IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ ELSE
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
+ ENDIF
+ ELSE
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
+ ENDIF
+ PHOSEL = PHOSTO-PHOSIN
+ APHOST = LOG10(PHOSTO)
+ APHOSE = LOG10(PHOSEL)
+ LFIRST = .FALSE.
+ ENDIF
+ STOT = ZERO
+ SELA = ZERO
+ PLAB = PL
+ ECMS = ECM
+ IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
+ WRITE(LOUT,1000) IP,IT
+ 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
+ & 'proj/target',2I4)
+ STOP
+ ENDIF
+
+ IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
+ ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
+ PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
+ ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
+ WRITE(LOUT,1001) PLAB,ECMS
+ 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
+ STOP
+ ENDIF
+
+* index of spectrum
+ IDXP = IP
+ IF (IP.GT.25) THEN
+ IF (AAM(IP).GT.ZERO) THEN
+ IF (ABS(IIBAR(IP)).GT.0) THEN
+ IDXP = 1
+ ELSE
+ IDXP = 13
+ ENDIF
+ ELSE
+ IDXP = 7
+ ENDIF
+ ENDIF
+ IDXT = 1
+ IF (IT.EQ.8) IDXT = 2
+ IDXS = IDXDAT(IDXP,IDXT)
+ IF (IDXS.EQ.0) RETURN
+
+* compute momentum bin indices
+ IF (PLAB.LT.PLABLO) THEN
+ IDX0 = 1
+ IDX1 = 1
+ ELSEIF (PLAB.GE.PLABHI) THEN
+ IDX0 = NPOINT
+ IDX1 = NPOINT
+ ELSE
+ APLAB = LOG10(PLAB)
+ IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
+ IDX0 = INT((APLAB-APLABL)/ADP1)+1
+ ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
+ IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
+ ENDIF
+ IDX1 = IDX0+1
+ ENDIF
+
+* interpolate cross section
+ IF (IDXS.GT.10) THEN
+ IDXS1 = IDXS/10
+ IDXS2 = IDXS-10*IDXS1
+ IF (IDX0.EQ.IDX1) THEN
+ IF (IDX0.EQ.1) THEN
+ ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
+ ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
+ ELSE
+ DUM0 = ZERO
+ CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ PHOSEL = PHOSTO-PHOSIN
+ ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ASTOT = 0.5D0*(ASTOT1+ASTOT2)
+ ASELA = 0.5D0*(ASELA1+ASELA2)
+ ENDIF
+ ELSE
+ FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
+ ASTOT1 = ASIGTO(IDXS1,IDX0)+
+ & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
+ ASTOT2 = ASIGTO(IDXS2,IDX0)+
+ & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
+ ASTOT = 0.5D0*(ASTOT1+ASTOT2)
+ ASELA1 = ASIGEL(IDXS1,IDX0)+
+ & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
+ ASELA2 = ASIGEL(IDXS2,IDX0)+
+ & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
+ ASELA = 0.5D0*(ASELA1+ASELA2)
+ ENDIF
+ ELSE
+ IF (IDX0.EQ.IDX1) THEN
+ IF (IDX0.EQ.1) THEN
+ ASTOT = ASIGTO(IDXS,IDX0)
+ ASELA = ASIGEL(IDXS,IDX0)
+ ELSE
+ DUM0 = ZERO
+ CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ PHOSEL = PHOSTO-PHOSIN
+ ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ENDIF
+ ELSE
+ FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
+ ASTOT = ASIGTO(IDXS,IDX0)+
+ & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
+ ASELA = ASIGEL(IDXS,IDX0)+
+ & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
+ ENDIF
+ ENDIF
+ STOT = 10.0D0**ASTOT
+ SELA = 10.0D0**ASELA
+
+ RETURN
+ END
+
+*$ CREATE DT_SIHNAB.FOR
+*COPY DT_SIHNAB
+*
+*===sihnab===============================================================*
+*
+ SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
+
+**********************************************************************
+* Pion 2-nucleon absorption cross sections. *
+* (sigma_tot for pi+ d --> p p, pi- d --> n n *
+* taken from Ritchie PRC 28 (1983) 926 ) *
+* This version dated 18.05.96 is written by S. Roesler *
+**********************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
+ PARAMETER (AMPR = 938.0D0,
+ & AMPI = 140.0D0,
+ & AMDE = TWO*AMPR,
+ & A = -1.2D0,
+ & B = 3.5D0,
+ & C = 7.4D0,
+ & D = 5600.0D0,
+ & ER = 2136.0D0)
+
+ SIGABS = ZERO
+ IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
+ & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
+ PTOT = PLAB*1.0D3
+ EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
+ IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
+ ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
+ SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
+* approximate 3N-abs., I=1-abs. etc.
+ SIGABS = SIGABS/0.40D0
+* pi0-absorption (rough approximation!!)
+ IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGEMU.FOR
+*COPY DT_SIGEMU
+*
+*===sigemu=============================================================*
+*
+ SUBROUTINE DT_SIGEMU
+
+************************************************************************
+* Combined cross section for target compounds. *
+* This version dated 6.4.98 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+ IF (MCGENE.NE.4) THEN
+ WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
+ WRITE(LOUT,'(15X,A)') '-----------------------'
+ ENDIF
+ DO 1 IE=1,NEBINI
+ DO 2 IQ=1,NQBINI
+ SIGTOT = ZERO
+ SIGELA = ZERO
+ SIGQEP = ZERO
+ SIGQET = ZERO
+ SIGQE2 = ZERO
+ SIGPRO = ZERO
+ SIGDEL = ZERO
+ SIGDQE = ZERO
+ ERRTOT = ZERO
+ ERRELA = ZERO
+ ERRQEP = ZERO
+ ERRQET = ZERO
+ ERRQE2 = ZERO
+ ERRPRO = ZERO
+ ERRDEL = ZERO
+ ERRDQE = ZERO
+ IF (NCOMPO.GT.0) THEN
+ DO 3 IC=1,NCOMPO
+ SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
+ SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
+ SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
+ SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
+ SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
+ SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
+ SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
+ SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
+ ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
+ ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
+ ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
+ ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
+ ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
+ ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
+ ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
+ ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
+ 3 CONTINUE
+ ERRTOT = SQRT(ERRTOT)
+ ERRELA = SQRT(ERRELA)
+ ERRQEP = SQRT(ERRQEP)
+ ERRQET = SQRT(ERRQET)
+ ERRQE2 = SQRT(ERRQE2)
+ ERRPRO = SQRT(ERRPRO)
+ ERRDEL = SQRT(ERRDEL)
+ ERRDQE = SQRT(ERRDQE)
+ ELSE
+ SIGTOT = XSTOT(IE,IQ,1)
+ SIGELA = XSELA(IE,IQ,1)
+ SIGQEP = XSQEP(IE,IQ,1)
+ SIGQET = XSQET(IE,IQ,1)
+ SIGQE2 = XSQE2(IE,IQ,1)
+ SIGPRO = XSPRO(IE,IQ,1)
+ SIGDEL = XSDEL(IE,IQ,1)
+ SIGDQE = XSDQE(IE,IQ,1)
+ ERRTOT = XETOT(IE,IQ,1)
+ ERRELA = XEELA(IE,IQ,1)
+ ERRQEP = XEQEP(IE,IQ,1)
+ ERRQET = XEQET(IE,IQ,1)
+ ERRQE2 = XEQE2(IE,IQ,1)
+ ERRPRO = XEPRO(IE,IQ,1)
+ ERRDEL = XEDEL(IE,IQ,1)
+ ERRDQE = XEDQE(IE,IQ,1)
+ ENDIF
+ IF (MCGENE.NE.4) THEN
+ WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
+ 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
+ WRITE(LOUT,1001) SIGTOT,ERRTOT
+ 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1002) SIGELA,ERRELA
+ 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1003) SIGQEP,ERRQEP
+ 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
+ & F11.5,' mb')
+ WRITE(LOUT,1004) SIGQET,ERRQET
+ 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
+ & F11.5,' mb')
+ WRITE(LOUT,1005) SIGQE2,ERRQE2
+ 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
+ & ' +-',F11.5,' mb')
+ WRITE(LOUT,1006) SIGPRO,ERRPRO
+ 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1007) SIGDEL,ERRDEL
+ 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1008) SIGDQE,ERRDQE
+ 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
+ ENDIF
+
+ 2 CONTINUE
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGGA.FOR
+*COPY DT_SIGGA
+*
+*===sigga==============================================================*
+*
+ SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
+
+************************************************************************
+* Total/inelastic photon-nucleus cross sections. *
+* !!!! Overwrites SHMAKI-initialization. Do not use it during *
+* production runs !!!! *
+* This version dated 27.03.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (AMPROT = 0.938D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ NT = NTI
+ X = XI
+ Q2 = Q2I
+ ECM = ECMI
+ XNU = XNUI
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
+ CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
+ STOT = XSTOT(1,1,1)
+ ETOT = XETOT(1,1,1)
+ SIN = XSPRO(1,1,1)
+ EIN = XEPRO(1,1,1)
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGGAT.FOR
+*COPY DT_SIGGAT
+*
+*===siggat=============================================================*
+*
+ SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
+
+************************************************************************
+* Total/inelastic photon-nucleus cross sections. *
+* Uses pre-tabulated cross section. *
+* This version dated 29.07.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ NTARG = ABS(NT)
+ I1 = 1
+ I2 = 1
+ RATE = ONE
+ IF (NEBINI.GT.1) THEN
+ IF (ECMI.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECMI.GT.ECMNN(1)) THEN
+ DO 1 I=2,NEBINI
+ IF (ECMI.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ONE
+ IF (NQBINI.GT.1) THEN
+ IF (Q2I.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (Q2I.GT.Q2G(1)) THEN
+ DO 3 I=2,NQBINI
+ IF (Q2I.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
+ GOTO 4
+ ENDIF
+ 3 CONTINUE
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ STOT = XSTOT(I1,J1,NTARG)+
+ & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
+ & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
+ & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
+ & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
+
+ RETURN
+ END
+
+*$ CREATE DT_SANO.FOR
+*COPY DT_SANO
+*
+*===sigano=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SANO(ECM)
+
+************************************************************************
+* This version dated 31.07.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (NE = 8)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+ DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
+ DATA ECMANO /
+ & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
+ & 0.100D+04,0.200D+04,0.500D+04
+ & /
+* fixed cut (3 GeV/c)
+ DATA FRAANO /
+ & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
+ & 0.062D+00,0.054D+00,0.042D+00
+ & /
+ DATA SIGHRD /
+ & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
+ & 3.3086D-01,7.6255D-01,2.1319D+00
+ & /
+* running cut (based on obsolete Phojet-caluclations, bugs..)
+C DATA FRAANO /
+C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
+C & 0.167E+00,0.150E+00,0.131E+00
+C & /
+C DATA SIGHRD /
+C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
+C & 2.5736E-01,4.5593E-01,8.2550E-01
+C & /
+
+ DT_SANO = ZERO
+ IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
+ J1 = 0
+ J2 = 0
+ RATE = ONE
+ IF (ECM.GE.ECMANO(NE)) THEN
+ J1 = NE
+ J2 = NE
+ ELSEIF (ECM.GT.ECMANO(1)) THEN
+ DO 1 IE=2,NE
+ IF (ECM.LT.ECMANO(IE)) THEN
+ J1 = IE-1
+ J2 = IE
+ RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ IF ((J1.GT.0).AND.(J2.GT.0)) THEN
+ AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
+ AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
+ DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGGP.FOR
+*COPY DT_SIGGP
+*
+*===siggp==============================================================*
+*
+ SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
+
+************************************************************************
+* Total/inelastic photon-nucleon cross sections. *
+* This version dated 30.04.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & ALPHEM = ONE/137.0D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+**PHOJET105a
+C CHARACTER*8 MDLNA
+C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+
+C PARAMETER (NPOINT=80)
+ PARAMETER (NPOINT=16)
+ DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+
+ STOT = ZERO
+ SINE = ZERO
+ SDIR = ZERO
+
+ W2 = ECMI**2
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
+ Q2 = Q2I
+ X = XI
+* photoprod.
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(W2+Q2-AAM(1)**2)
+* DIS
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
+ X = Q2/(W2+Q2-AAM(1)**2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = (W2-AAM(1)**2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ W2 = Q2*(ONE-X)/X+AAM(1)**2
+ ELSE
+ WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
+ STOP
+ ENDIF
+ ECM = SQRT(W2)
+
+ IF (MODEGA.EQ.1) THEN
+ SCALE = SQRT(Q2)
+ CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
+ & IDPDF)
+C W = SQRT(W2)
+
+C ALLMF2 = PHO_ALLM97(Q2,W)
+
+C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
+ STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
+ SINE = ZERO
+ SDIR = ZERO
+ ELSEIF (MODEGA.EQ.2) THEN
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = W2/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = W2/4.0D0
+ ELSE
+ AMHI2 = W2
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+ XAMLO = LOG( AMLO2+Q2 )
+ XAMHI = LOG( AMHI2+Q2 )
+**PHOJET105a
+C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+ CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+
+**
+ SUM = ZERO
+ DO 1 J=1,NPOINT
+ AM2 = EXP(ABSZX(J))-Q2
+ IF (AM2.LT.16.0D0) THEN
+ R = TWO
+ ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
+ R = 10.0D0/3.0D0
+ ELSE
+ R = 11.0D0/3.0D0
+ ENDIF
+C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
+ FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
+ & * (ONE+EPSPOL*Q2/AM2)
+ SUM = SUM+WEIGHT(J)*FAC
+ 1 CONTINUE
+ SINE = SUM
+ SDIR = DT_SIGVP(X,Q2)
+ STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
+ SDIR = SDIR/(0.588D0+RL2+Q2)
+C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
+ ELSEIF (MODEGA.EQ.3) THEN
+ CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
+ ELSEIF (MODEGA.EQ.4) THEN
+* load cross sections from PHOJET interpolation table
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 2 I=2,ISIMAX
+ IF (ECM.LE.SIGECM(IP,I)) GOTO 3
+ 2 CONTINUE
+ 3 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+* cross section dependence on photon virtuality
+ FSUP1 = ZERO
+ DO 4 I=1,3
+ FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
+ & /(1.D0+Q2/PARMDL(30+I))**2
+ 4 CONTINUE
+ FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
+ FAC1 = FAC1*FSUP1
+ FAC2 = FAC2*FSUP1
+ FSUP2 = 1.0D0
+ STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+**re:
+ STOT = STOT-SDIR
+**
+ SDIR = SDIR/(FSUP1*FSUP2)
+**re:
+ STOT = STOT+SDIR
+**
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGVEL.FOR
+*COPY DT_SIGVEL
+*
+*===sigvel=============================================================*
+*
+ SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
+
+************************************************************************
+* Cross section for elastic vector meson production *
+* This version dated 10.05.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & ALPHEM = ONE/137.0D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ W2 = ECMI**2
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
+ Q2 = Q2I
+ X = XI
+* photoprod.
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(W2+Q2-AAM(1)**2)
+* DIS
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
+ X = Q2/(W2+Q2-AAM(1)**2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = (W2-AAM(1)**2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ W2 = Q2*(ONE-X)/X+AAM(1)**2
+ ELSE
+ WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
+ STOP
+ ENDIF
+ ECM = SQRT(W2)
+
+ AMV = AAM(IDXV)
+ AMV2 = AMV**2
+
+ BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
+ & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
+ ROSH = 0.1D0
+ STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
+ SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
+
+ IF (IDXV.EQ.33) THEN
+ COUPL = 0.00365D0
+ ELSE
+ STOP
+ ENDIF
+ SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
+ SIG2 = SELVP
+ SVEL = COUPL * (AMV2/(AMV2+Q2))**2
+ & * (ONE+EPSPOL*Q2/AMV2) * SELVP
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGVP.FOR
+*COPY DT_SIGVP
+*
+*===sigvp==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
+
+************************************************************************
+* sigma_Vp *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & AMPROT = 0.938D0,
+ & ALPHEM = ONE/137.0D0)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ X = XI
+ Q2 = Q2I
+ IF (XI.LE.ZERO) X = 0.0001D0
+ IF (Q2I.LE.ZERO) Q2 = 0.0001D0
+
+ ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
+
+ SCALE = SQRT(Q2)
+ IF (MODEGA.EQ.1) THEN
+ CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
+ & IDPDF)
+C W = ECM
+
+C ALLMF2 = PHO_ALLM97(Q2,W)
+
+C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
+C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
+C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
+ DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
+ ELSEIF (MODEGA.EQ.4) THEN
+ CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
+C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
+ DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
+ ELSE
+ STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
+ ENDIF
+
+ RETURN
+
+ END
+
+*$ CREATE DT_RRM2.FOR
+*COPY DT_RRM2
+*
+*===RRM2===============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ S = Q2*(ONE-X)/X+AAM(1)**2
+ ECM = SQRT(S)
+
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+
+ AM1C2 = 16.0D0
+ AM2C2 = 121.0D0
+ IF (AMHI2.LE.AM1C2) THEN
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
+ ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
+ & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
+ ELSE
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
+ & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
+ & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_RM2.FOR
+*COPY DT_RM2
+*
+*===RM2================================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ IF (RL2.LE.ZERO) THEN
+ DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
+ & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
+ & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
+ ELSE
+ TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
+ TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
+ DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
+ & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
+ & +EPSPOL*(
+ & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
+ & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SAM2.FOR
+*COPY DT_SAM2
+*
+*===SAM2===============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
+ & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ S = ECM**2
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+
+ AM1C2 = 16.0D0
+ AM2C2 = 121.0D0
+ YLO = LOG(AMLO2+Q2)
+ YC1 = LOG(AM1C2+Q2)
+ YC2 = LOG(AM2C2+Q2)
+ YHI = LOG(AMHI2+Q2)
+ IF (AMHI2.LE.AM1C2) THEN
+ FACHI = TWO
+ ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
+ FACHI = TENTRD
+ ELSE
+ FACHI = ELVTRD
+ ENDIF
+
+ 1 CONTINUE
+ YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
+ IF (YSAM2.LE.YC1) THEN
+ FAC = TWO
+ ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
+ FAC = TENTRD
+ ELSE
+ FAC = ELVTRD
+ ENDIF
+ WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
+ XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
+ IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
+
+ DT_SAM2 = EXP(YSAM2)-Q2
+
+ RETURN
+ END
+
+*$ CREATE DT_CKMT.FOR
+*COPY DT_CKMT
+*
+*===ckmt===============================================================*
+*
+ SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
+ & F2,IPAR)
+
+************************************************************************
+* This version dated 31.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
+
+ PARAMETER (Q02 = 2.0D0,
+ & DQ2 = 10.05D0,
+ & Q12 = Q02+DQ2)
+
+ DIMENSION PD(-6:6),SEA(3),VAL(2)
+
+ CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
+ CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
+ ADQ2 = LOG10(Q12)-LOG10(Q02)
+ F2P = (F2Q1-F2Q0)/ADQ2
+ CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
+ CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
+ F2PP = (F2PQ1-F2PQ0)/ADQ2
+ FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
+
+ Q2 = MAX(SCALE**2.0D0,TINY10)
+ SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
+ IF (Q2.LT.Q02) THEN
+ CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
+ UPV = VAL(1)
+ DNV = VAL(2)
+ USEA = SEA(1)
+ DSEA = SEA(2)
+ STR = SEA(3)
+ CHM = 0.0D0
+ BOT = 0.0D0
+ TOP = 0.0D0
+ GL = GLU
+ ELSE
+ CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
+ F2 = F2*SMOOTH
+ UPV = PD(2)-PD(3)
+ DNV = PD(1)-PD(3)
+ USEA = PD(3)
+ DSEA = PD(3)
+ STR = PD(3)
+ CHM = PD(4)
+ BOT = PD(5)
+ TOP = PD(6)
+ GL = PD(0)
+C UPV = UPV*SMOOTH
+C DNV = DNV*SMOOTH
+C USEA = USEA*SMOOTH
+C DSEA = DSEA*SMOOTH
+C STR = STR*SMOOTH
+C CHM = CHM*SMOOTH
+C GL = GL*SMOOTH
+ ENDIF
+
+ RETURN
+ END
+C
+
+*$ CREATE DT_CKMTX.FOR
+*COPY DT_CKMTX
+ SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 45 Pomeron
+C 100 Deuteron
+C
+C output: PD(-6:6) x*f(x) parton distribution functions
+C (PDFLIB convention: d = PD(1), u = PD(2) )
+C
+C**********************************************************************
+
+ SAVE
+ DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION QQ(7)
+C
+ Q2=SNGL(SCALE2)
+ Q1S=Q2
+ XX=SNGL(X)
+C QCD lambda for evolution
+ OWLAM = 0.23D0
+ OWLAM2=OWLAM**2
+C Q0**2 for evolution
+ Q02 = 2.D0
+C
+C
+C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
+C q(6)=x*charm, q(7)=x*gluon
+C
+ SB=0.
+ IF(Q2-Q02) 1,1,2
+ 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
+ 1 CONTINUE
+ IF(IPAR.EQ.2212) THEN
+ CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
+ CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
+ CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
+ CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
+ CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
+ CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
+ CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
+C ELSEIF (IPAR.EQ.45) THEN
+C CALL CKMTPO(1,0,XX,SB,QQ(1))
+C CALL CKMTPO(2,0,XX,SB,QQ(2))
+C CALL CKMTPO(3,0,XX,SB,QQ(3))
+C CALL CKMTPO(4,0,XX,SB,QQ(4))
+C CALL CKMTPO(5,0,XX,SB,QQ(5))
+C CALL CKMTPO(8,0,XX,SB,QQ(6))
+C CALL CKMTPO(7,0,XX,SB,QQ(7))
+ ELSEIF (IPAR.EQ.100) THEN
+ CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
+ CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
+ CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
+ CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
+ CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
+ CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
+ CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'CKMTX: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+C
+ PD(-6) = 0.D0
+ PD(-5) = 0.D0
+ PD(-4) = DBLE(QQ(6))
+ PD(-3) = DBLE(QQ(3))
+ PD(-2) = DBLE(QQ(4))
+ PD(-1) = DBLE(QQ(5))
+ PD(0) = DBLE(QQ(7))
+ PD(1) = DBLE(QQ(2))
+ PD(2) = DBLE(QQ(1))
+ PD(3) = DBLE(QQ(3))
+ PD(4) = DBLE(QQ(6))
+ PD(5) = 0.D0
+ PD(6) = 0.D0
+ IF(IPAR.EQ.45) THEN
+ CDN = (PD(1)-PD(-1))/2.D0
+ CUP = (PD(2)-PD(-2))/2.D0
+ PD(-1) = PD(-1) + CDN
+ PD(-2) = PD(-2) + CUP
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
+ & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
+ & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
+ END
+C
+
+*$ CREATE DT_PDF0.FOR
+*COPY DT_PDF0
+*
+*===pdf0===============================================================*
+*
+ SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
+
+************************************************************************
+* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
+* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
+* IPAR = 2212 proton *
+* = 100 deuteron *
+* This version dated 31.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
+
+ PARAMETER (
+ & AA = 0.1502D0,
+ & BBDEU = 1.2D0,
+ & BUD = 0.754D0,
+ & BDD = 0.4495D0,
+ & BUP = 1.2064D0,
+ & BDP = 0.1798D0,
+ & DELTA0 = 0.07684D0,
+ & D = 1.117D0,
+ & C = 3.5489D0,
+ & A = 0.2631D0,
+ & B = 0.6452D0,
+ & ALPHAR = 0.415D0,
+ & E = 0.1D0
+ & )
+
+ PARAMETER (NPOINT=16)
+C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+ DIMENSION SEA(3),VAL(2)
+
+ DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
+ AN = 1.5D0*(1.0D0+Q2/(Q2+C))
+* proton, deuteron
+ IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
+ CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
+ SEA(1) = 0.75D0*SEA0
+ SEA(2) = SEA(1)
+ SEA(3) = SEA(1)
+ VAL(1) = 9.0D0/4.0D0*VALU0
+ VAL(2) = 9.0D0*VALD0
+ GLU0 = SEA(1)/(1.0D0-X)
+ F2 = SEA0+VALU0+VALD0
+ F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
+ & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
+ & 1.0D0/9.0D0*(2.0D0*SEA(3))
+ IF (ABS(F2-F2PDF).GT.TINY9) THEN
+ WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
+ STOP
+ ENDIF
+**PHOJET105a
+C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
+
+**
+C SUMQ = ZERO
+C SUMG = ZERO
+C DO 1 J=1,NPOINT
+C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
+C VALU0 = 9.0D0/4.0D0*VALU0
+C VALD0 = 9.0D0*VALD0
+C SEA0 = 0.75D0*SEA0
+C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
+C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
+C 1 CONTINUE
+C GLU = GLU0*(1.0D0-SUMQ)/SUMG
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'PDF0: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_CKMTQ0.FOR
+*COPY DT_CKMTQ0
+*
+*===ckmtq0=============================================================*
+*
+ SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
+
+************************************************************************
+* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
+* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
+* IPAR = 2212 proton *
+* = 100 deuteron *
+* This version dated 31.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
+
+ PARAMETER (
+ & AA = 0.1502D0,
+ & BBDEU = 1.2D0,
+ & BUD = 0.754D0,
+ & BDD = 0.4495D0,
+ & BUP = 1.2064D0,
+ & BDP = 0.1798D0,
+ & DELTA0 = 0.07684D0,
+ & D = 1.117D0,
+ & C = 3.5489D0,
+ & A = 0.2631D0,
+ & B = 0.6452D0,
+ & ALPHAR = 0.415D0,
+ & E = 0.1D0
+ & )
+
+ DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
+ AN = 1.5D0*(1.0D0+Q2/(Q2+C))
+* proton, deuteron
+ IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
+ IF (IPAR.EQ.2212) THEN
+ BU = BUP
+ BD = BDP
+ ELSE
+ BU = BUD
+ BD = BDD
+ ENDIF
+ SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
+ & (Q2/(Q2+A))**(1.0D0+DELTA)
+ VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
+ & (Q2/(Q2+B))**(ALPHAR)
+ VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
+ & (Q2/(Q2+B))**(ALPHAR)
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+ RETURN
+ END
+C
+C
+
+*$ CREATE DT_CKMTDE.FOR
+*COPY DT_CKMTDE
+ SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
+C
+C**********************************************************************
+C Deuteron - PDFs
+C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
+C ANS = PDF(I)
+C This version by S. Roesler, 30.01.96
+C**********************************************************************
+
+ SAVE
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.13/
+C
+ DATA (DL(K),K= 1, 85) /
+ &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
+ &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
+ &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
+ &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
+ &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
+ &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
+ &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
+ &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
+ &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
+ &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
+ &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
+ &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
+ &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
+ &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
+ &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
+ &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
+ &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
+ DATA (DL(K),K= 86, 170) /
+ &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
+ &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
+ &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
+ &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
+ &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
+ &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
+ &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
+ &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
+ DATA (DL(K),K= 171, 255) /
+ &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
+ &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
+ &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
+ &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
+ &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
+ &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
+ &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
+ &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
+ &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
+ &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
+ &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
+ &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
+ &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
+ &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
+ &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
+ &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
+ &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
+ DATA (DL(K),K= 256, 340) /
+ &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
+ &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
+ &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
+ &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
+ &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
+ &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
+ &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
+ &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
+ DATA (DL(K),K= 341, 425) /
+ &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
+ &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
+ &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
+ &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
+ &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
+ &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
+ &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
+ &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
+ &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
+ &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
+ &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
+ &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
+ &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
+ &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
+ &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
+ &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
+ &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
+ DATA (DL(K),K= 426, 510) /
+ &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
+ &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
+ &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
+ &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
+ &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
+ &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
+ &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
+ &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
+ DATA (DL(K),K= 511, 595) /
+ &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
+ &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
+ &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
+ &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
+ &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
+ &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
+ &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
+ &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
+ &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
+ &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
+ &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
+ &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
+ &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
+ &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
+ &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
+ &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
+ &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
+ DATA (DL(K),K= 596, 680) /
+ &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
+ &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
+ &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
+ &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
+ &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
+ &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
+ &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
+ &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
+ DATA (DL(K),K= 681, 765) /
+ &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
+ &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
+ &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
+ &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
+ &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
+ &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
+ &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
+ &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
+ &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
+ &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
+ &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
+ &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
+ &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
+ &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
+ &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
+ &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 766, 850) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
+ &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
+ &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
+ &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
+ &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
+ &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
+ &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
+ &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
+ &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
+ &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
+ DATA (DL(K),K= 851, 935) /
+ &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
+ &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
+ &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
+ &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
+ &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
+ &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
+ &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
+ &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
+ &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
+ &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
+ &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
+ &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
+ &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
+ &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 936, 1020) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
+ &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
+ &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
+ &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
+ &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
+ &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
+ &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
+ &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
+ &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
+ &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
+ &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
+ &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
+ DATA (DL(K),K= 1021, 1105) /
+ &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
+ &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
+ &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
+ &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
+ &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
+ &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
+ &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
+ &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
+ &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
+ &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
+ &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
+ &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
+ &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
+ &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
+ &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
+ &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
+ &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
+ &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
+ &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
+ &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
+ &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
+ &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
+ &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
+ &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
+ &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
+ &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
+ &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
+ &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
+ &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
+ &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
+ &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
+ &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
+ &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
+ &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
+ &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
+ &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
+ &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
+ &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
+ &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
+ &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
+ &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
+ &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
+ &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
+ &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
+ &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
+ &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
+ &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
+ &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
+ &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
+ &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
+ &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
+ &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
+ &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
+ &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
+ &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
+ &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
+ DATA (DL(K),K= 1446, 1530) /
+ &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
+ &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
+ &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
+ &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
+ &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
+ &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
+ &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
+ &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
+ &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
+ &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
+ &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
+ &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
+ &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
+ &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
+ &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
+ &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
+ &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
+ DATA (DL(K),K= 1531, 1615) /
+ &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
+ &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
+ &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
+ &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
+ &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
+ &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
+ &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
+ &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
+ &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
+ &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
+ &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
+ &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
+ &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
+ &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
+ &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
+ &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
+ &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
+ &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
+ &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
+ &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
+ &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
+ &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
+ &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
+ &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
+ DATA (DL(K),K= 1701, 1785) /
+ &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
+ &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
+ &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
+ &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
+ &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
+ &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
+ &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
+ &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
+ DATA (DL(K),K= 1786, 1870) /
+ &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
+ &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
+ &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
+ &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
+ &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
+ &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
+ &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
+ &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
+ &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
+ &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
+ &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
+ &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
+ &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
+ &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
+ &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
+ &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
+ &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
+ DATA (DL(K),K= 1871, 1955) /
+ &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
+ &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
+ &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
+ &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
+ &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
+ &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
+ &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
+ &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
+ &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
+ &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
+ &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
+ &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
+ &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
+ &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
+ &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
+ &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
+ &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
+ &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
+ &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
+ &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
+ &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
+ &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
+ &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
+ &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
+ DATA (DL(K),K= 2041, 2125) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
+ &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
+ &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
+ &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
+ &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
+ &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
+ &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
+ &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
+ &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
+ &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
+ &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
+ &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
+ &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
+ &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
+ &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
+ &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
+ &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
+ &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
+ &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
+ &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
+ &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
+ &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
+ &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2211, 2295) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
+ &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
+ &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
+ &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
+ &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
+ &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
+ &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
+ &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
+ &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
+ &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
+ &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
+ DATA (DL(K),K= 2296, 2380) /
+ &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
+ &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
+ &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
+ &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
+ &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
+ &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
+ &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
+ &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
+ &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
+ &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
+ &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
+ &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
+ &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2381, 2465) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
+ &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
+ &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
+ &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
+ &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
+ &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
+ &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
+ &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
+ &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
+ &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
+ &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
+ &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
+ &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
+ DATA (DL(K),K= 2466, 2550) /
+ &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
+ &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
+ &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
+ &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
+ &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
+ &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
+ &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
+ &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
+ &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
+ &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
+ &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2551, 2635) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
+ &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
+ &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
+ &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
+ &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
+ &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
+ &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
+ &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
+ &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
+ &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
+ &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
+ &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
+ &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
+ &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
+ &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
+ DATA (DL(K),K= 2636, 2720) /
+ &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
+ &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
+ &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
+ &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
+ &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
+ &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
+ &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
+ &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
+ &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
+ &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
+ &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
+ &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
+ &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
+ &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
+ &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
+ &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
+ &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
+ &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
+ &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
+ &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
+ &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
+ &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
+ &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
+ &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
+ &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
+ DATA (DL(K),K= 2806, 2890) /
+ &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
+ &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
+ &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
+ &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
+ &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
+ &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
+ &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
+ &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
+ DATA (DL(K),K= 2891, 2975) /
+ &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
+ &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
+ &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
+ &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
+ &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
+ &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
+ &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
+ &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
+ &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
+ &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
+ &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
+ &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
+ &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
+ &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
+ &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
+ &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
+ &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
+ DATA (DL(K),K= 2976, 3060) /
+ &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
+ &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
+ &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
+ &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
+ &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
+ &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
+ &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
+ &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
+ DATA (DL(K),K= 3061, 3145) /
+ &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
+ &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
+ &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
+ &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
+ &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
+ &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
+ &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
+ &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
+ &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
+ &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
+ &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
+ &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
+ &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
+ &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
+ &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
+ &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
+ &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
+ &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
+ &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
+ &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
+ &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
+ &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
+ &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
+ &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
+ DATA (DL(K),K= 3231, 3315) /
+ &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
+ &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
+ &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
+ &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
+ &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
+ &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
+ &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
+ &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
+ &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
+ &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
+ &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
+ &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
+ &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
+ &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
+ &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
+ &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
+ &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
+ DATA (DL(K),K= 3316, 3400) /
+ &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
+ &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
+ &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
+ &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
+ &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
+ &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
+ &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
+ &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
+ DATA (DL(K),K= 3401, 3485) /
+ &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
+ &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
+ &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
+ &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
+ &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
+ &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
+ &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
+ &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
+ &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
+ &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
+ &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
+ &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
+ &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
+ &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
+ &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
+ &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3486, 3570) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
+ &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
+ &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
+ &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
+ &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
+ &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
+ &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
+ &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
+ &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
+ &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
+ DATA (DL(K),K= 3571, 3655) /
+ &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
+ &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
+ &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
+ &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
+ &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
+ &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
+ &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
+ &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
+ &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
+ &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
+ &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
+ &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
+ &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
+ &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3656, 3740) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
+ &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
+ &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
+ &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
+ &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
+ &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
+ &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
+ &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
+ &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
+ &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
+ &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
+ &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
+ DATA (DL(K),K= 3741, 3825) /
+ &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
+ &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
+ &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
+ &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
+ &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
+ &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
+ &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
+ &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
+ &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
+ &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
+ &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
+ &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3826, 3910) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
+ &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
+ &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
+ &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
+ &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
+ &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
+ &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
+ &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
+ &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
+ &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
+ &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
+ &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
+ &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
+ &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
+ DATA (DL(K),K= 3911, 3995) /
+ &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
+ &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
+ &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
+ &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
+ &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
+ &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
+ &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
+ &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
+ &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
+ &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+C
+ ANS = 0.
+ IF (X.GT.0.9985) RETURN
+ IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
+C
+ IS = S/DELTA+1
+ IS1 = IS+1
+ DO 1 L=1,25
+ KL = L+NDRV*25
+ F1(L) = GF(I,IS,KL)
+ F2(L) = GF(I,IS1,KL)
+ 1 CONTINUE
+ A1 = DT_CKMTFF(X,F1)
+ A2 = DT_CKMTFF(X,F2)
+C A1=ALOG(A1)
+C A2=ALOG(A2)
+ S1 = (IS-1)*DELTA
+ S2 = S1+DELTA
+ ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
+C ANS=EXP(ANS)
+ RETURN
+ END
+C
+C
+
+*$ CREATE DT_CKMTPR.FOR
+*COPY DT_CKMTPR
+ SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
+C
+C**********************************************************************
+C Proton - PDFs
+C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
+C ANS = PDF(I)
+C This version by S. Roesler, 31.01.96
+C**********************************************************************
+
+ SAVE
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.10/
+C
+ DATA (DL(K),K= 1, 85) /
+ &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
+ &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
+ &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
+ &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
+ &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
+ &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
+ &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
+ &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
+ &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
+ &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
+ &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
+ &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
+ &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
+ &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
+ &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
+ &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
+ &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
+ DATA (DL(K),K= 86, 170) /
+ &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
+ &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
+ &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
+ &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
+ &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
+ &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
+ &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
+ &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
+ &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
+ &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
+ &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
+ &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
+ &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
+ &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
+ &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
+ DATA (DL(K),K= 171, 255) /
+ &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
+ &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
+ &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
+ &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
+ &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
+ &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
+ &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
+ &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
+ &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
+ &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
+ &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
+ &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
+ &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
+ &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
+ &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
+ &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
+ &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
+ DATA (DL(K),K= 256, 340) /
+ &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
+ &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
+ &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
+ &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
+ &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
+ &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
+ &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
+ &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
+ &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
+ &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
+ &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
+ &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
+ &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
+ &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
+ &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
+ DATA (DL(K),K= 341, 425) /
+ &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
+ &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
+ &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
+ &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
+ &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
+ &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
+ &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
+ &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
+ &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
+ &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
+ &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
+ &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
+ &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
+ &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
+ &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
+ &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
+ &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
+ DATA (DL(K),K= 426, 510) /
+ &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
+ &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
+ &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
+ &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
+ &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
+ &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
+ &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
+ &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
+ &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
+ &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
+ &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
+ &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
+ &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
+ &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
+ &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
+ DATA (DL(K),K= 511, 595) /
+ &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
+ &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
+ &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
+ &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
+ &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
+ &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
+ &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
+ &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
+ &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
+ &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
+ &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
+ &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
+ &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
+ &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
+ &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
+ &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
+ &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
+ DATA (DL(K),K= 596, 680) /
+ &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
+ &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
+ &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
+ &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
+ &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
+ &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
+ &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
+ &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
+ &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
+ &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
+ &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
+ &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
+ &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
+ &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
+ &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
+ DATA (DL(K),K= 681, 765) /
+ &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
+ &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
+ &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
+ &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
+ &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
+ &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
+ &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
+ &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
+ &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
+ &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
+ &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
+ &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
+ &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
+ &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
+ &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
+ &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
+ &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
+ DATA (DL(K),K= 766, 850) /
+ &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
+ &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
+ &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
+ &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
+ &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
+ &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
+ &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
+ &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
+ &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
+ &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
+ &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
+ &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
+ &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
+ &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
+ &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
+ DATA (DL(K),K= 851, 935) /
+ &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
+ &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
+ &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
+ &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
+ &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
+ &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
+ &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
+ &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
+ &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
+ &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
+ &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
+ &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
+ &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
+ &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
+ &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
+ &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
+ &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
+ DATA (DL(K),K= 936, 1020) /
+ &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
+ &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
+ &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
+ &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
+ &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
+ &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
+ &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
+ &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
+ &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
+ &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
+ &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
+ &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
+ &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
+ &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
+ &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
+ DATA (DL(K),K= 1021, 1105) /
+ &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
+ &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
+ &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
+ &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
+ &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
+ &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
+ &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
+ &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
+ &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
+ &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
+ &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
+ &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
+ &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
+ &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
+ &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
+ &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
+ &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
+ &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
+ &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
+ &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
+ &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
+ &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
+ &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
+ &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
+ &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
+ &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
+ &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
+ &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
+ &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
+ &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
+ &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
+ &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
+ &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
+ &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
+ &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
+ &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
+ &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
+ &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
+ &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
+ &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
+ &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
+ &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
+ &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
+ &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
+ &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
+ &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
+ &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
+ &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
+ &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
+ &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
+ &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
+ &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
+ &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
+ &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
+ &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
+ &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
+ &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
+ &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
+ &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
+ &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
+ &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
+ &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
+ &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
+ &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
+ &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
+ &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
+ &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
+ &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
+ &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
+ &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
+ &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
+ &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
+ &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
+ &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
+ &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
+ &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
+ DATA (DL(K),K= 1446, 1530) /
+ &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
+ &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
+ &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
+ &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
+ &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
+ &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
+ &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
+ &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
+ &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
+ &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
+ &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
+ &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
+ &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
+ &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
+ &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
+ &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
+ &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
+ DATA (DL(K),K= 1531, 1615) /
+ &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
+ &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
+ &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
+ &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
+ &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
+ &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
+ &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
+ &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
+ &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
+ &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
+ &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
+ &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
+ &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
+ &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
+ &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
+ &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
+ &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
+ &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
+ &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
+ &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
+ &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
+ &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
+ &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
+ &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
+ &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
+ &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
+ &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
+ &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
+ &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
+ &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
+ &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
+ DATA (DL(K),K= 1701, 1785) /
+ &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
+ &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
+ &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
+ &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
+ &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
+ &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
+ &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
+ &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
+ &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
+ &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
+ &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
+ &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
+ &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
+ &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
+ &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
+ DATA (DL(K),K= 1786, 1870) /
+ &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
+ &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
+ &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
+ &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
+ &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
+ &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
+ &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
+ &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
+ &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
+ &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
+ &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
+ &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
+ &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
+ &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
+ &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
+ &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
+ &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
+ DATA (DL(K),K= 1871, 1955) /
+ &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
+ &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
+ &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
+ &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
+ &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
+ &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
+ &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
+ &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
+ &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
+ &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
+ &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
+ &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
+ &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
+ &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
+ &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
+ &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
+ &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
+ &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
+ &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
+ &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
+ &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
+ &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
+ &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
+ &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
+ &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
+ &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
+ &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
+ &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
+ &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
+ &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
+ &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
+ DATA (DL(K),K= 2041, 2125) /
+ &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
+ &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
+ &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
+ &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
+ &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
+ &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
+ &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
+ &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
+ &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
+ &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
+ &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
+ &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
+ &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
+ &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
+ &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
+ &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
+ &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
+ &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
+ &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
+ &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
+ &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
+ &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
+ &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
+ &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
+ &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
+ &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
+ &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
+ &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
+ &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
+ &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
+ &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
+ DATA (DL(K),K= 2211, 2295) /
+ &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
+ &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
+ &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
+ &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
+ &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
+ &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
+ &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
+ &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
+ &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
+ &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
+ &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
+ &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
+ &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
+ &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
+ &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
+ DATA (DL(K),K= 2296, 2380) /
+ &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
+ &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
+ &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
+ &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
+ &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
+ &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
+ &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
+ &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
+ &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
+ &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
+ &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
+ &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
+ &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
+ &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
+ &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
+ &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
+ &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
+ DATA (DL(K),K= 2381, 2465) /
+ &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
+ &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
+ &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
+ &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
+ &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
+ &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
+ &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
+ &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
+ &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
+ &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
+ &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
+ &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
+ &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
+ &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
+ &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
+ DATA (DL(K),K= 2466, 2550) /
+ &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
+ &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
+ &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
+ &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
+ &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
+ &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
+ &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
+ &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
+ &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
+ &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
+ &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
+ &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
+ &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
+ &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
+ &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
+ &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
+ &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
+ DATA (DL(K),K= 2551, 2635) /
+ &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
+ &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
+ &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
+ &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
+ &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
+ &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
+ &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
+ &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
+ &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
+ &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
+ &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
+ &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
+ &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
+ &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
+ &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
+ DATA (DL(K),K= 2636, 2720) /
+ &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
+ &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
+ &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
+ &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
+ &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
+ &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
+ &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
+ &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
+ &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
+ &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
+ &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
+ &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
+ &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
+ &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
+ &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
+ &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
+ &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
+ &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
+ &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
+ &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
+ &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
+ &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
+ &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
+ &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
+ &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
+ &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
+ &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
+ &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
+ &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
+ &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
+ &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
+ &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
+ DATA (DL(K),K= 2806, 2890) /
+ &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
+ &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
+ &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
+ &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
+ &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
+ &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
+ &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
+ &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
+ &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
+ &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
+ &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
+ &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
+ &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
+ &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
+ &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
+ DATA (DL(K),K= 2891, 2975) /
+ &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
+ &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
+ &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
+ &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
+ &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
+ &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
+ &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
+ &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
+ &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
+ &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
+ &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
+ &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
+ &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
+ &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
+ &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
+ &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
+ &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
+ DATA (DL(K),K= 2976, 3060) /
+ &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
+ &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
+ &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
+ &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
+ &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
+ &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
+ &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
+ &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
+ &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
+ &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
+ &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
+ &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
+ &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
+ &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
+ &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
+ DATA (DL(K),K= 3061, 3145) /
+ &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
+ &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
+ &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
+ &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
+ &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
+ &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
+ &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
+ &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
+ &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
+ &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
+ &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
+ &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
+ &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
+ &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
+ &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
+ &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
+ &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
+ &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
+ &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
+ &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
+ &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
+ &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
+ &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
+ &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
+ &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
+ &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
+ &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
+ &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
+ &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
+ &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
+ &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
+ DATA (DL(K),K= 3231, 3315) /
+ &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
+ &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
+ &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
+ &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
+ &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
+ &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
+ &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
+ &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
+ &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
+ &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
+ &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
+ &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
+ &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
+ &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
+ &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
+ &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
+ &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
+ DATA (DL(K),K= 3316, 3400) /
+ &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
+ &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
+ &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
+ &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
+ &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
+ &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
+ &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
+ &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
+ &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
+ &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
+ &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
+ &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
+ &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
+ &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
+ &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
+ DATA (DL(K),K= 3401, 3485) /
+ &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
+ &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
+ &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
+ &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
+ &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
+ &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
+ &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
+ &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
+ &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
+ &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
+ &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
+ &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
+ &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
+ &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
+ &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
+ &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
+ &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
+ DATA (DL(K),K= 3486, 3570) /
+ &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
+ &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
+ &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
+ &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
+ &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
+ &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
+ &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
+ &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
+ &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
+ &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
+ &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
+ &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
+ &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
+ &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
+ &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
+ DATA (DL(K),K= 3571, 3655) /
+ &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
+ &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
+ &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
+ &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
+ &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
+ &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
+ &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
+ &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
+ &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
+ &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
+ &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
+ &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
+ &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
+ &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
+ &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
+ &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
+ &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
+ DATA (DL(K),K= 3656, 3740) /
+ &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
+ &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
+ &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
+ &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
+ &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
+ &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
+ &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
+ &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
+ &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
+ &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
+ &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
+ &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
+ &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
+ &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
+ &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
+ DATA (DL(K),K= 3741, 3825) /
+ &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
+ &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
+ &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
+ &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
+ &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
+ &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
+ &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
+ &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
+ &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
+ &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
+ &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
+ &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
+ &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
+ &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
+ &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
+ &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
+ &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
+ DATA (DL(K),K= 3826, 3910) /
+ &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
+ &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
+ &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
+ &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
+ &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
+ &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
+ &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
+ &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
+ &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
+ &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
+ &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
+ &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
+ &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
+ &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
+ &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
+ DATA (DL(K),K= 3911, 3995) /
+ &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
+ &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
+ &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
+ &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
+ &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
+ &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
+ &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
+ &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
+ &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
+ &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
+ &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
+ &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
+ &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
+ &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
+ &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
+ &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
+ &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+C
+ ANS = 0.
+ IF (X.GT.0.9985) RETURN
+ IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
+C
+ IS = S/DELTA+1
+ IS1 = IS+1
+ DO 1 L=1,25
+ KL = L+NDRV*25
+ F1(L) = GF(I,IS,KL)
+ F2(L) = GF(I,IS1,KL)
+ 1 CONTINUE
+ A1 = DT_CKMTFF(X,F1)
+ A2 = DT_CKMTFF(X,F2)
+C A1=ALOG(A1)
+C A2=ALOG(A2)
+ S1 = (IS-1)*DELTA
+ S2 = S1+DELTA
+ ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
+C ANS=EXP(ANS)
+ RETURN
+ END
+C
+
+*$ CREATE DT_CKMTFF.FOR
+*COPY DT_CKMTFF
+ FUNCTION DT_CKMTFF(X,FVL)
+C**********************************************************************
+C
+C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
+C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
+C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
+C IN MAIN ROUTINE.
+C
+C**********************************************************************
+
+ SAVE
+ DIMENSION FVL(25),XGRID(25)
+ DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
+ *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
+C
+ DT_CKMTFF=0.
+ DO 1 I=1,NX
+ IF(X.LT.XGRID(I)) GO TO 2
+ 1 CONTINUE
+ 2 I=I-1
+ IF(I.EQ.0) THEN
+ I=I+1
+ ELSE IF(I.GT.23) THEN
+ I=23
+ ENDIF
+ J=I+1
+ K=J+1
+ AXI=LOG(XGRID(I))
+ BXI=LOG(1.-XGRID(I))
+ AXJ=LOG(XGRID(J))
+ BXJ=LOG(1.-XGRID(J))
+ AXK=LOG(XGRID(K))
+ BXK=LOG(1.-XGRID(K))
+ FI=LOG(ABS(FVL(I)) +1.E-15)
+ FJ=LOG(ABS(FVL(J)) +1.E-16)
+ FK=LOG(ABS(FVL(K)) +1.E-17)
+ DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
+ ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
+ $ BXI))/DET
+ ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
+ BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
+ IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
+ 1RETURN
+C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
+C WRITE(6,2001) X,FVL
+C 2001 FORMAT(8E12.4)
+C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
+C ENDIF
+ DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
+ RETURN
+ END
+
+*$ CREATE DT_FLUINI.FOR
+*COPY DT_FLUINI
+*
+*===fluini=============================================================*
+*
+ SUBROUTINE DT_FLUINI
+
+************************************************************************
+* Initialisation of the nucleon-nucleon cross section fluctuation *
+* treatment. The original version by J. Ranft. *
+* This version dated 21.04.95 is revised by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER ( A = 0.1D0,
+ & B = 0.893D0,
+ & OM = 1.1D0,
+ & N = 6,
+ & DX = 0.003D0)
+
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+ DIMENSION FLUSI(NBINS),FLUIX(NBINS)
+
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
+ & 'treated')
+
+ FLUSU = ZERO
+ FLUSUU = ZERO
+
+ DO 1 I=1,NBINS
+ X = DBLE(I)*DX
+ FLUIX(I) = X
+ FLUS = ((X-B)/(OM*B))**N
+ IF (FLUS.LE.20.0D0) THEN
+ FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
+ ELSE
+ FLUSI(I) = ZERO
+ ENDIF
+ FLUSU = FLUSU+FLUSI(I)
+ 1 CONTINUE
+ DO 2 I=1,NBINS
+ FLUSUU = FLUSUU+FLUSI(I)/FLUSU
+ FLUSI(I) = FLUSUU
+ 2 CONTINUE
+
+C WRITE(LOUT,1001)
+C1001 FORMAT(1X,'FLUCTUATIONS')
+C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
+
+ DO 3 I=1,NBINS
+ AF = DBLE(I)*0.001D0
+ DO 4 J=1,NBINS
+ IF (AF.LE.FLUSI(J)) THEN
+ FLUIXX(I) = FLUIX(J)
+ GOTO 5
+ ENDIF
+ 4 CONTINUE
+ 5 CONTINUE
+ 3 CONTINUE
+ FLUIXX(1) = FLUIX(1)
+ FLUIXX(NBINS) = FLUIX(NBINS)
+
+ RETURN
+ END
+
+*$ CREATE DT_SIGTBL.FOR
+*COPY DT_SIGTBL
+*
+*===sigtab=============================================================*
+*
+ SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
+
+************************************************************************
+* This version dated 18.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
+
+ LOGICAL LINIT
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
+ DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
+ & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 5/
+ DATA LINIT /.FALSE./
+
+* precalculation and tabulation of elastic cross sections
+ IF (ABS(MODE).EQ.1) THEN
+ IF (MODE.EQ.1)
+ & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
+ PLABLX = LOG10(PLO)
+ PLABHX = LOG10(PHI)
+ DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
+ DO 1 I=1,NBINS+1
+ PLAB = PLABLX+DBLE(I-1)*DPLAB
+ PLAB = 10**PLAB
+ DO 2 IPROJ=1,23
+ IDX = IDSIG(IPROJ)
+ IF (IDX.GT.0) THEN
+C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
+C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
+ DUMZER = ZERO
+ CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
+ CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
+ ENDIF
+ 2 CONTINUE
+ IF (MODE.EQ.1) THEN
+ WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
+ & (SIGEN(IDX,I),IDX=1,5)
+ 1000 FORMAT(F5.1,10F7.2)
+ ENDIF
+ 1 CONTINUE
+ IF (MODE.EQ.1) CLOSE(LDAT)
+ LINIT = .TRUE.
+ ELSE
+ SIGE = -ONE
+ IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
+ & .AND.(PTOT.LE.PHI) ) THEN
+ IDX = IDSIG(JP)
+ IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
+ PLABX = LOG10(PTOT)
+ IF (PLABX.LE.PLABLX) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (PLABX.GE.PLABHX) THEN
+ I1 = NBINS+1
+ I2 = NBINS+1
+ ELSE
+ I1 = INT((PLABX-PLABLX)/DPLAB)+1
+ I2 = I1+1
+ ENDIF
+ PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
+ PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
+ PBIN = PLAB2X-PLAB1X
+ IF (PBIN.GT.TINY10) THEN
+ RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
+ ELSE
+ RATX = ZERO
+ ENDIF
+ IF (JT.EQ.1) THEN
+ SIG1 = SIGEP(IDX,I1)
+ SIG2 = SIGEP(IDX,I2)
+ ELSE
+ SIG1 = SIGEN(IDX,I1)
+ SIG2 = SIGEN(IDX,I2)
+ ENDIF
+ SIGE = SIG1+RATX*(SIG2-SIG1)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_XSTABL.FOR
+*COPY DT_XSTABL
+*
+*===xstabl=============================================================*
+*
+ SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
+ LOGICAL LLAB,LELOG,LQLOG
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+ DIMENSION WHAT(6)
+
+ LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
+ ELO = ABS(WHAT(1))
+ EHI = ABS(WHAT(2))
+ IF (ELO.GT.EHI) ELO = EHI
+ LELOG = WHAT(3).LT.ZERO
+ NEBINS = MAX(INT(ABS(WHAT(3))),1)
+ DEBINS = (EHI-ELO)/DBLE(NEBINS)
+ IF (LELOG) THEN
+ AELO = LOG10(ELO)
+ AEHI = LOG10(EHI)
+ ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
+ ENDIF
+ Q2LO = WHAT(4)
+ Q2HI = WHAT(5)
+ IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
+ LQLOG = WHAT(6).LT.ZERO
+ NQBINS = MAX(INT(ABS(WHAT(6))),1)
+ DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
+ IF (LQLOG) THEN
+ AQ2LO = LOG10(Q2LO)
+ AQ2HI = LOG10(Q2HI)
+ ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
+ ENDIF
+
+ IF ( ELO.EQ. EHI) NEBINS = 0
+ IF (Q2LO.EQ.Q2HI) NQBINS = 0
+
+ WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
+ 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
+ & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
+ & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
+ & ' A_p = ',I3,' A_t = ',I3,/)
+
+C IF (IJPROJ.NE.7) THEN
+ WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
+* normalize fractions of emulsion components
+ IF (NCOMPO.GT.0) THEN
+ SUMFRA = ZERO
+ DO 10 I=1,NCOMPO
+ SUMFRA = SUMFRA+EMUFRA(I)
+ 10 CONTINUE
+ IF (SUMFRA.GT.ZERO) THEN
+ DO 11 I=1,NCOMPO
+ EMUFRA(I) = EMUFRA(I)/SUMFRA
+ 11 CONTINUE
+ ENDIF
+ ENDIF
+C ELSE
+C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
+C ENDIF
+ DO 1 I=1,NEBINS+1
+ IF (LELOG) THEN
+ E = 10**(AELO+DBLE(I-1)*ADEBIN)
+ ELSE
+ E = ELO+DBLE(I-1)*DEBINS
+ ENDIF
+ DO 2 J=1,NQBINS+1
+ IF (LQLOG) THEN
+ Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
+ ELSE
+ Q2 = Q2LO+DBLE(J-1)*DQBINS
+ ENDIF
+c IF (IJPROJ.NE.7) THEN
+ IF (LLAB) THEN
+ PLAB = ZERO
+ ECM = ZERO
+ CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
+ ELSE
+ ECM = E
+ ENDIF
+ XI = ZERO
+ Q2I = ZERO
+ IF (IJPROJ.EQ.7) Q2I = Q2
+ IF (NCOMPO.GT.0) THEN
+ DO 20 IC=1,NCOMPO
+ IIT = IEMUMA(IC)
+ CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
+ 20 CONTINUE
+ ELSE
+ CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
+C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
+ ENDIF
+ IF (NCOMPO.GT.0) THEN
+ XTOT = ZERO
+ ETOT = ZERO
+ XELA = ZERO
+ EELA = ZERO
+ XQEP = ZERO
+ EQEP = ZERO
+ XQET = ZERO
+ EQET = ZERO
+ XQE2 = ZERO
+ EQE2 = ZERO
+ XPRO = ZERO
+ EPRO = ZERO
+ XPRO1= ZERO
+ XDEL = ZERO
+ EDEL = ZERO
+ XDQE = ZERO
+ EDQE = ZERO
+ DO 21 IC=1,NCOMPO
+ XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
+ ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
+ XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
+ EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
+ XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
+ EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
+ XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
+ EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
+ XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
+ EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
+ XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
+ EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
+ XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
+ EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
+ XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
+ EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
+ YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
+ & -XSQEP(1,1,IC)-XSQET(1,1,IC)
+ & -XSQE2(1,1,IC)
+ XPRO1= XPRO1+EMUFRA(IC)*YPRO
+ 21 CONTINUE
+ ETOT = SQRT(ETOT)
+ EELA = SQRT(EELA)
+ EQEP = SQRT(EQEP)
+ EQET = SQRT(EQET)
+ EQE2 = SQRT(EQE2)
+ EPRO = SQRT(EPRO)
+ EDEL = SQRT(EDEL)
+ EDQE = SQRT(EDQE)
+ WRITE(LOUT,'(8E9.3)')
+ & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
+C WRITE(LOUT,'(4E9.3)')
+C & E,XDEL,XDQE,XDEL+XDQE
+ ELSE
+ WRITE(LOUT,'(11E10.3)')
+ & E,
+ & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
+ & XSQE2(1,1,1),XSPRO(1,1,1),
+ & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
+ & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
+ & XSDEL(1,1,1)+XSDQE(1,1,1)
+C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
+C & XSDEL(1,1,1)+XSDQE(1,1,1)
+ ENDIF
+c ELSE
+c IF (LLAB) THEN
+c IF (IT.GT.1) THEN
+c IF (IXSQEL.EQ.0) THEN
+cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
+cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
+c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
+c & STOT,ETOT,SIN,EIN,STOT0)
+c IF (IRATIO.EQ.1) THEN
+c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
+cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
+cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
+c*!! save cross sections
+c STOTA = STOT
+c ETOTA = ETOT
+c STOTP = STGP
+c*!!
+c STOT = STOT/(DBLE(IT)*STGP)
+c SIN = SIN/(DBLE(IT)*SIGP)
+c STOT0 = STGP
+c ETOT = ZERO
+c EIN = ZERO
+c ENDIF
+c ELSE
+c WRITE(LOUT,*)
+c & ' XSTABL: qel. xs. not implemented for nuclei'
+c STOP
+c ENDIF
+c ELSE
+c ETOT = ZERO
+c EIN = ZERO
+c STOT0= ZERO
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
+c ELSE
+c SIN = ZERO
+c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
+c ENDIF
+c ENDIF
+c ELSE
+c IF (IT.GT.1) THEN
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
+c & STOT,ETOT,SIN,EIN,STOT0)
+c IF (IRATIO.EQ.1) THEN
+c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
+c*!! save cross sections
+c STOTA = STOT
+c ETOTA = ETOT
+c STOTP = STGP
+c*!!
+c STOT = STOT/(DBLE(IT)*STGP)
+c SIN = SIN/(DBLE(IT)*SIGP)
+c STOT0 = STGP
+c ETOT = ZERO
+c EIN = ZERO
+c ENDIF
+c ELSE
+c WRITE(LOUT,*)
+c & ' XSTABL: qel. xs. not implemented for nuclei'
+c STOP
+c ENDIF
+c ELSE
+c ETOT = ZERO
+c EIN = ZERO
+c STOT0= ZERO
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
+c ELSE
+c SIN = ZERO
+c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
+c ENDIF
+c ENDIF
+c ENDIF
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
+c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
+c ENDIF
+ 2 CONTINUE
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_TESTXS.FOR
+*COPY DT_TESTXS
+*
+*===testxs=============================================================*
+*
+ SUBROUTINE DT_TESTXS
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XSTOT(26,2),XSELA(26,2)
+
+ OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
+ OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
+ OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
+ OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
+ DUMECM = 0.0D0
+ PLABL = 0.01D0
+ PLABH = 10000.0D0
+ NBINS = 120
+ APLABL = LOG10(PLABL)
+ APLABH = LOG10(PLABH)
+ ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
+ DO 1 I=1,NBINS+1
+ ADP = APLABL+DBLE(I-1)*ADPLAB
+ P = 10.0D0**ADP
+ DO 2 J=1,26
+ CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
+ CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
+ 2 CONTINUE
+ WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
+ WRITE(11,1000) P,(XSELA(K,1),K=1,26)
+ WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
+ WRITE(13,1000) P,(XSELA(K,2),K=1,26)
+ 1 CONTINUE
+ 1000 FORMAT(F8.3,26F9.3)
+
+ RETURN
+ END
+************************************************************************
+* *
+* DTUNUC 2.0: library routines *
+* processed by S. Roesler, 6.5.95 *
+* *
+************************************************************************
+*
+* 1) Handling of parton momenta
+* SUBROUTINE MASHEL
+* SUBROUTINE DFERMI
+*
+* 2) Handling of parton flavors and particle indices
+* INTEGER FUNCTION IPDG2B
+* INTEGER FUNCTION IB2PDG
+* INTEGER FUNCTION IQUARK
+* INTEGER FUNCTION IBJQUA
+* INTEGER FUNCTION ICIHAD
+* INTEGER FUNCTION IPDGHA
+* INTEGER FUNCTION MCHAD
+* SUBROUTINE FLAHAD
+*
+* 3) Energy-momentum and quantum number conservation check routines
+* SUBROUTINE EMC1
+* SUBROUTINE EMC2
+* SUBROUTINE EVTEMC
+* SUBROUTINE EVTFLC
+* SUBROUTINE EVTCHG
+*
+* 4) Transformations
+* SUBROUTINE LTINI
+* SUBROUTINE LTRANS
+* SUBROUTINE LTNUC
+* SUBROUTINE DALTRA
+* SUBROUTINE DTRAFO
+* SUBROUTINE STTRAN
+* SUBROUTINE MYTRAN
+* SUBROUTINE LT2LAO
+* SUBROUTINE LT2LAB
+*
+* 5) Sampling from distributions
+* INTEGER FUNCTION NPOISS
+* DOUBLE PRECISION FUNCTION SAMPXB
+* DOUBLE PRECISION FUNCTION SAMPEX
+* DOUBLE PRECISION FUNCTION SAMSQX
+* DOUBLE PRECISION FUNCTION BETREJ
+* DOUBLE PRECISION FUNCTION DGAMRN
+* DOUBLE PRECISION FUNCTION DBETAR
+* SUBROUTINE RANNOR
+* SUBROUTINE DPOLI
+* SUBROUTINE DSFECF
+* SUBROUTINE RACO
+*
+* 6) Special functions, algorithms and service routines
+* DOUBLE PRECISION FUNCTION YLAMB
+* SUBROUTINE SORT
+* SUBROUTINE SORT1
+* SUBROUTINE DT_XTIME
+*
+* 7) Random number generator package
+* DOUBLE PRECISION FUNCTION DT_RNDM
+* SUBROUTINE DT_RNDMST
+* SUBROUTINE DT_RNDMIN
+* SUBROUTINE DT_RNDMOU
+* SUBROUTINE DT_RNDMTE
+*
+************************************************************************
+* *
+* 1) Handling of parton momenta *
+* *
+************************************************************************
+*$ CREATE DT_MASHEL.FOR
+*COPY DT_MASHEL
+*
+*===mashel=============================================================*
+*
+ SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
+
+************************************************************************
+* *
+* rescaling of momenta of two partons to put both *
+* on mass shell *
+* *
+* input: PA1,PA2 input momentum vectors *
+* XM1,2 desired masses of particles afterwards *
+* P1,P2 changed momentum vectors *
+* *
+* The original version is written by R. Engel. *
+* This version dated 12.12.94 is modified by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+ DIMENSION PA1(4),PA2(4),P1(4),P2(4)
+
+ IREJ = 0
+
+* Lorentz transformation into system CMS
+ PX = PA1(1)+PA2(1)
+ PY = PA1(2)+PA2(2)
+ PZ = PA1(3)+PA2(3)
+ EE = PA1(4)+PA2(4)
+ XPTOT = SQRT(PX**2+PY**2+PZ**2)
+ XMS = (EE-XPTOT)*(EE+XPTOT)
+ IF(XMS.LT.(XM1+XM2)**2) THEN
+C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
+ GOTO 9999
+ ENDIF
+ XMS = SQRT(XMS)
+ BGX = PX/XMS
+ BGY = PY/XMS
+ BGZ = PZ/XMS
+ GAM = EE/XMS
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
+ & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
+* rotation angles
+ COD = P1(3)/PTOT1
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(P1(1)**2+P1(2)**2)
+ SID = PPT/PTOT1
+ COF = ONE
+ SIF = ZERO
+ IF(PTOT1*SID.GT.TINY10) THEN
+ COF = P1(1)/(SID*PTOT1)
+ SIF = P1(2)/(SID*PTOT1)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+* new CM momentum and energies (for masses XM1,XM2)
+ XM12 = SIGN(XM1**2,XM1)
+ XM22 = SIGN(XM2**2,XM2)
+ SS = XMS**2
+ PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
+ EE1 = SQRT(XM12+PCMP**2)
+ EE2 = XMS-EE1
+* back rotation
+ MODE = 1
+ CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
+ & PTOT1,P1(1),P1(2),P1(3),P1(4))
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
+ & PTOT2,P2(1),P2(2),P2(3),P2(4))
+* check consistency
+ DEL = XMS*0.0001D0
+ IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
+ IDEV = 1
+ ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
+ IDEV = 2
+ ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
+ IDEV = 3
+ ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
+ IDEV = 4
+ ELSE
+ IDEV = 0
+ ENDIF
+ IF (IDEV.NE.0) THEN
+ WRITE(LOUT,'(/1X,A,I3)')
+ & 'MASHEL: inconsistent transformation',IDEV
+ WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
+ WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
+ WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
+ WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
+ WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_DFERMI.FOR
+*COPY DT_DFERMI
+*
+*===dfermi=============================================================*
+*
+ SUBROUTINE DT_DFERMI(GPART)
+
+************************************************************************
+* Find largest of three random numbers. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION G(3)
+
+ DO 10 I=1,3
+ G(I)=DT_RNDM(GPART)
+ 10 CONTINUE
+ IF (G(3).LT.G(2)) GOTO 40
+ IF (G(3).LT.G(1)) GOTO 30
+ GPART = G(3)
+ 20 RETURN
+ 30 GPART = G(1)
+ GOTO 20
+ 40 IF (G(2).LT.G(1)) GOTO 30
+ GPART = G(2)
+ GOTO 20
+
+ END
+
+************************************************************************
+* *
+* 2) Handling of parton flavors and particle indices *
+* *
+************************************************************************
+*$ CREATE IDT_IPDG2B.FOR
+*COPY IDT_IPDG2B
+*
+*===ipdg2b=============================================================*
+*
+ INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
+
+************************************************************************
+* *
+* conversion of quark numbering scheme *
+* *
+* input: PDG parton numbering *
+* for diquarks: NN number of the constituent quark *
+* (e.g. ID=2301,NN=1 -> ICONV2=1) *
+* *
+* output: BAMJET particle codes *
+* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
+* 2 d 8 a-d -2 a-d *
+* 3 s 9 a-s -3 a-s *
+* 4 c 10 a-c -4 a-c *
+* *
+* This is a modified version of ICONV2 written by R. Engel. *
+* This version dated 13.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ IDA = ABS(ID)
+* diquarks
+ IF (IDA.GT.6) THEN
+ KF = 3
+ IF (IDA.GE.1000) KF = 4
+ IDA = IDA/(10**(KF-NN))
+ IDA = MOD(IDA,10)
+ ENDIF
+* exchange up and dn quarks
+ IF (IDA.EQ.1) THEN
+ IDA = 2
+ ELSEIF (IDA.EQ.2) THEN
+ IDA = 1
+ ENDIF
+* antiquarks
+ IF (ID.LT.0) THEN
+ IF (MODE.EQ.1) THEN
+ IDA = IDA+6
+ ELSE
+ IDA = -IDA
+ ENDIF
+ ENDIF
+ IDT_IPDG2B = IDA
+
+ RETURN
+ END
+
+*$ CREATE IDT_IB2PDG.FOR
+*COPY IDT_IB2PDG
+*
+*===ib2pdg=============================================================*
+*
+ INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
+
+************************************************************************
+* *
+* conversion of quark numbering scheme *
+* *
+* input: BAMJET particle codes *
+* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
+* 2 d 8 a-d -2 a-d *
+* 3 s 9 a-s -3 a-s *
+* 4 c 10 a-c -4 a-c *
+* *
+* output: PDG parton numbering *
+* *
+* This version dated 13.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
+ DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
+ DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
+ &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
+ &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
+
+ IDA = ID1
+ IDB = ID2
+ IF (MODE.EQ.1) THEN
+ IF (ID1.GT.6) IDA = -(ID1-6)
+ IF (ID2.GT.6) IDB = -(ID2-6)
+ ENDIF
+ IF (ID2.EQ.0) THEN
+ IDT_IB2PDG = IHKKQ(IDA)
+ ELSE
+ IDT_IB2PDG = IHKKQQ(IDA,IDB)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE IDT_IQUARK.FOR
+*COPY IDT_IQUARK
+*
+*===ipdgqu=============================================================*
+*
+ INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
+
+************************************************************************
+* *
+* quark contents according to PDG conventions *
+* (random selection in case of quark mixing) *
+* *
+* input: IDBAMJ BAMJET particle code *
+* K 1..3 quark number *
+* *
+* output: 1 d (anti --> neg.) *
+* 2 u *
+* 3 s *
+* 4 c *
+* *
+* This version written by R. Engel. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IQ = IDT_IBJQUA(K,IDBAMJ)
+* quark-antiquark
+ IF (IQ.GT.6) THEN
+ IQ = 6-IQ
+ ENDIF
+* exchange of up and down
+ IF (ABS(IQ).EQ.1) THEN
+ IQ = SIGN(2,IQ)
+ ELSEIF (ABS(IQ).EQ.2) THEN
+ IQ = SIGN(1,IQ)
+ ENDIF
+ IDT_IQUARK = IQ
+
+ RETURN
+ END
+
+*$ CREATE IDT_IBJQUA.FOR
+*COPY IDT_IBJQUA
+*
+*===ibamq==============================================================*
+*
+ INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
+
+************************************************************************
+* *
+* quark contents according to BAMJET conventions *
+* (random selection in case of quark mixing) *
+* *
+* input: IDBAMJ BAMJET particle code *
+* K 1..3 quark number *
+* *
+* output: 1 u 7 u bar *
+* 2 d 8 d bar *
+* 3 s 9 s bar *
+* 4 c 10 c bar *
+* *
+* This version written by R. Engel. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ITAB(3,210)
+ DATA ((ITAB(I,K),I=1,3),K=1,30) /
+ & 1, 1, 2, 7, 7, 8, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 2, 2, 7, 8, 8,
+*sr 10.1.94
+C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 3, 8, 0,
+*
+ & 1, 8, 0, 2, 7, 0, 1, 9, 0,
+*sr 10.1.94
+C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
+ & 3, 7, 0, 3, 1, 2, 9, 7, 8,
+*sr 10.1.94
+C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
+ & 2, 9, 0, 2, 2, 3, 1, 1, 3,
+*
+ & 1, 2, 3, 201,202, 0, 2, 9, 0,
+ & 3, 8, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=31,60) /
+ & 3, 9, 0, 1, 8, 0, 203,204, 0,
+ & 2, 7, 0, 0, 0, 0, 1, 9, 0,
+ & 2, 9, 0, 3, 7, 0, 3, 8, 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, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 1, 1, 1, 1, 2,
+ & 1, 2, 2, 2, 2, 2, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=61,90) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 7, 7, 7, 7, 7, 8, 7, 8, 8,
+ & 8, 8, 8, 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,
+ & 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 /
+ DATA ((ITAB(I,K),I=1,3),K=91,120) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 3, 9, 0,
+ & 1, 3, 3, 2, 3, 3, 7, 7, 9,
+ & 7, 8, 9, 8, 8, 9, 7, 9, 9,
+ & 8, 9, 9, 1, 1, 3, 1, 2, 3,
+ & 2, 2, 3, 1, 3, 3, 2, 3, 3,
+ & 3, 3, 3, 7, 7, 9, 7, 8, 9,
+ & 8, 8, 9, 7, 9, 9, 8, 9, 9,
+ & 9, 9, 9, 4, 7, 0, 4, 8, 0,
+ & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=121,150) /
+ & 3, 10, 0, 4, 10, 0, 4, 7, 0,
+ & 4, 8, 0, 2, 10, 0, 1, 10, 0,
+ & 4, 9, 0, 3, 10, 0, 4, 10, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 2, 4, 1, 3, 4,
+ & 2, 3, 4, 1, 1, 4, 0, 0, 0,
+ & 2, 2, 4, 0, 0, 0, 0, 0, 0,
+ & 3, 3, 4, 1, 4, 4, 2, 4, 4,
+ & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
+ DATA ((ITAB(I,K),I=1,3),K=151,180) /
+ & 8, 9, 10, 7, 7, 10, 0, 0, 0,
+ & 8, 8, 10, 0, 0, 0, 0, 0, 0,
+ & 9, 9, 10, 7, 10, 10, 8, 10, 10,
+ & 9, 10, 10, 1, 1, 4, 1, 2, 4,
+ & 2, 2, 4, 1, 3, 4, 2, 3, 4,
+ & 3, 3, 4, 1, 4, 4, 2, 4, 4,
+ & 3, 4, 4, 4, 4, 4, 7, 7, 10,
+ & 7, 8, 10, 8, 8, 10, 7, 9, 10,
+ & 8, 9, 10, 9, 9, 10, 7, 10, 10,
+ & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
+ DATA ((ITAB(I,K),I=1,3),K=181,210) /
+ & 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, 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, 1, 7, 0,
+ & 2, 8, 0, 1, 7, 0, 2, 8, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA IDOLD /0/
+
+ ONE = 1.0D0
+ IF (ITAB(1,IDBAMJ).LE.200) THEN
+ ID = ITAB(K,IDBAMJ)
+ ELSE
+ IF(IDOLD.NE.IDBAMJ) THEN
+ IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
+ & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
+ ELSE
+ IDOLD = 0
+ ENDIF
+ ID = ITAB(K,IT)
+ ENDIF
+ IDOLD = IDBAMJ
+ IDT_IBJQUA = ID
+
+ RETURN
+ END
+
+*$ CREATE IDT_ICIHAD.FOR
+*COPY IDT_ICIHAD
+*
+*===icihad=============================================================*
+*
+ INTEGER FUNCTION IDT_ICIHAD(MCIND)
+
+************************************************************************
+* Conversion of particle index PDG proposal --> BAMJET-index scheme *
+* This is a completely new version dated 25.10.95. *
+* Renamed to be not in conflict with the modified PHOJET-version *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+
+ IDT_ICIHAD = 0
+ KPDG = ABS(MCIND)
+ IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
+ IF (MCIND.LT.0) THEN
+ JSIGN = 1
+ ELSE
+ JSIGN = 2
+ ENDIF
+ IF (KPDG.GE.10000) THEN
+ DO 1 I=1,19
+ IDT_ICIHAD = IBAM5(JSIGN,I)
+ IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 1 CONTINUE
+ ELSEIF (KPDG.GE.1000) THEN
+ DO 2 I=1,29
+ IDT_ICIHAD = IBAM4(JSIGN,I)
+ IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 2 CONTINUE
+ ELSEIF (KPDG.GE.100) THEN
+ DO 3 I=1,22
+ IDT_ICIHAD = IBAM3(JSIGN,I)
+ IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 3 CONTINUE
+ ELSEIF (KPDG.GE.10) THEN
+ DO 4 I=1,7
+ IDT_ICIHAD = IBAM2(JSIGN,I)
+ IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 4 CONTINUE
+ ENDIF
+ 5 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE IDT_IPDGHA.FOR
+*COPY IDT_IPDGHA
+*
+*===ipdgha=============================================================*
+*
+ INTEGER FUNCTION IDT_IPDGHA(MCIND)
+
+************************************************************************
+* Conversion of particle index BAMJET-index scheme --> PDG proposal *
+* Adopted from the original by S. Roesler. This version dated 12.5.95 *
+* Renamed to be not in conflict with the modified PHOJET-version *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+
+ IDT_IPDGHA = IAMCIN(MCIND)
+
+ RETURN
+ END
+
+*$ CREATE DT_FLAHAD.FOR
+*COPY DT_FLAHAD
+*
+*===flahad=============================================================*
+*
+ SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
+
+************************************************************************
+* sampling of FLAvor composition for HADrons/photons *
+* ID BAMJET-id of hadron *
+* IF1,2,3 flavor content *
+* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
+* Note: - u,d numbering as in BAMJET *
+* - ID .le. 30 !! *
+* This version dated 12.03.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+
+ DIMENSION JSEL(3,6)
+ DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
+
+ ONE = 1.0D0
+ IF (ID.EQ.7) THEN
+* photon (charge dependent flavour sampling)
+ K = INT(DT_RNDM(ONE)*6.D0+1.D0)
+ IF (K.LE.4) THEN
+ IF1 = 2
+ IF2 = -2
+ ELSE IF(K.EQ.5) THEN
+ IF1 = 1
+ IF2 = -1
+ ELSE
+ IF1 = 3
+ IF2 = -3
+ ENDIF
+ IF(DT_RNDM(ONE).LT.0.5D0) THEN
+ K = IF1
+ IF1 = IF2
+ IF2 = K
+ ENDIF
+ IF3 = 0
+ ELSE
+* hadron
+ IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
+ IF1 = MQUARK(JSEL(1,IX),ID)
+ IF2 = MQUARK(JSEL(2,IX),ID)
+ IF3 = MQUARK(JSEL(3,IX),ID)
+ IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
+ IF1 = IF3
+ IF3 = 0
+ ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
+ IF2 = IF3
+ IF3 = 0
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE IDT_MCHAD.FOR
+*COPY IDT_MCHAD
+*
+*===mchad==============================================================*
+*
+ INTEGER FUNCTION IDT_MCHAD(ITDTU)
+
+************************************************************************
+* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
+* Adopted from the original by S. Roesler. This version dated 6.5.95 *
+* *
+* Last change 28.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ITRANS(210)
+ DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
+ &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
+ &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
+ &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
+ &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
+ &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
+ &9, 9, 9, 85*- 1,7*-1,1,8,-1/
+
+ IF ( ITDTU .GT. 0 ) THEN
+ IDT_MCHAD = ITRANS(ITDTU)
+ ELSE
+ IDT_MCHAD = -1
+ END IF
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 3) Energy-momentum and quantum number conservation check routines *
+* *
+************************************************************************
+*$ CREATE DT_EMC1.FOR
+*COPY DT_EMC1
+*
+*===emc1===============================================================*
+*
+ SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
+
+************************************************************************
+* This version dated 15.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10)
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
+
+ IREJ = 0
+
+ IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
+ & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
+
+ IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
+ IF (MODE.EQ.1) THEN
+ CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
+ ELSEIF (MODE.EQ.2) THEN
+ CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
+ ENDIF
+ CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
+ ELSEIF (MODE.LT.0) THEN
+ IF (MODE.EQ.-1) THEN
+ CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
+ ELSEIF (MODE.EQ.-2) THEN
+ CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
+ ENDIF
+ CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
+ ENDIF
+
+ IF (ABS(MODE).EQ.3) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_EMC2.FOR
+*COPY DT_EMC2
+*
+*===emc2===============================================================*
+*
+ SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
+ & MODE,IPOS,IREJ)
+
+************************************************************************
+* MODE = 1 energy-momentum cons. check *
+* = 2 flavor-cons. check *
+* = 3 energy-momentum & flavor cons. check *
+* = 4 energy-momentum & charge cons. check *
+* = 5 energy-momentum & flavor & charge cons. check *
+* This version dated 16.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ IREJ = 0
+ IREJ1 = 0
+ IREJ2 = 0
+ IREJ3 = 0
+
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
+ & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
+ & (ISTHKK(I).EQ.IP5)) THEN
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
+ & .OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & 2,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
+ ENDIF
+ IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
+ & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
+ & (ISTHKK(I).EQ.IN5)) THEN
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
+ & .OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
+ & 2,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
+ ENDIF
+ 1 CONTINUE
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
+ IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_EVTEMC.FOR
+*COPY DT_EVTEMC
+*
+*===evtemc=============================================================*
+*
+ SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
+
+************************************************************************
+* This version dated 13.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
+ & ZERO=0.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ IREJ = 0
+
+ MODE = IMODE
+ CHKLEV = TINY10
+ IF (MODE.EQ.4) THEN
+ CHKLEV = TINY2
+ MODE = 3
+ ELSEIF (MODE.EQ.5) THEN
+ CHKLEV = TINY1
+ MODE = 3
+ ELSEIF (MODE.EQ.-1) THEN
+ CHKLEV = EIO
+ MODE = 3
+ ENDIF
+
+ IF (ABS(MODE).EQ.3) THEN
+ PXDEV = PX
+ PYDEV = PY
+ PZDEV = PZ
+ EDEV = E
+ IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
+ IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
+ & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
+ IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
+ & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
+ & ' event ',NEVHKK,
+ & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ GOTO 9999
+ ENDIF
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.1) THEN
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ ENDIF
+
+ PX = PX+PXIO
+ PY = PY+PYIO
+ PZ = PZ+PZIO
+ E = E+EIO
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_EVTFLC.FOR
+*COPY DT_EVTFLC
+*
+*===evtflc=============================================================*
+*
+ SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
+
+************************************************************************
+* Flavor conservation check. *
+* ID identity of particle *
+* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
+* = 2 ID for particle/resonance in BAMJET numbering scheme *
+* = 3 ID for particle/resonance in PDG numbering scheme *
+* MODE = 1 initialization and add ID *
+* =-1 initialization and subtract ID *
+* = 2 add ID *
+* =-2 subtract ID *
+* = 3 check flavor cons. *
+* IPOS flag to give position of call of EVTFLC to output *
+* unit in case of violation *
+* This version dated 10.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10)
+
+ IREJ = 0
+
+ IF (MODE.EQ.3) THEN
+ IF (IFL.NE.0) THEN
+ WRITE(LOUT,'(1X,A,I3,A,I3)')
+ & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
+ & ' ! IFL = ',IFL
+ IFL = 0
+ GOTO 9999
+ ENDIF
+ IFL = 0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.1) IFL = 0
+ IF (ID.EQ.0) RETURN
+
+ IF (ID1.EQ.1) THEN
+ IDD = ABS(ID)
+ NQ = 1
+ IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
+ IF (IDD.GE.1000) NQ = 3
+ DO 1 I=1,NQ
+ IFBAM = IDT_IPDG2B(ID,I,2)
+ IF (ABS(IFBAM).EQ.1) THEN
+ IFBAM = SIGN(2,IFBAM)
+ ELSEIF (ABS(IFBAM).EQ.2) THEN
+ IFBAM = SIGN(1,IFBAM)
+ ENDIF
+ IF (MODE.GT.0) THEN
+ IFL = IFL+IFBAM
+ ELSE
+ IFL = IFL-IFBAM
+ ENDIF
+ 1 CONTINUE
+ RETURN
+ ENDIF
+
+ IDD = ID
+ IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
+ IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
+ DO 2 I=1,3
+ IF (MODE.GT.0) THEN
+ IFL = IFL+IDT_IQUARK(I,IDD)
+ ELSE
+ IFL = IFL-IDT_IQUARK(I,IDD)
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+*$ CREATE DT_EVTCHG.FOR
+*COPY DT_EVTCHG
+*
+*===evtchg=============================================================*
+*
+ SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
+
+************************************************************************
+* Charge conservation check. *
+* ID identity of particle (PDG-numbering scheme) *
+* MODE = 1 initialization *
+* =-2 subtract ID-charge *
+* = 2 add ID-charge *
+* = 3 check charge cons. *
+* IPOS flag to give position of call of EVTCHG to output *
+* unit in case of violation *
+* This version dated 10.01.95 is written by S. Roesler *
+* Last change: s.r. 21.01.01 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ IREJ = 0
+
+ IF (MODE.EQ.1) THEN
+ ICH = 0
+ IBAR = 0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.3) THEN
+ IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
+ WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
+ & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
+ & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
+ ICH = 0
+ IBAR = 0
+ GOTO 9999
+ ENDIF
+ ICH = 0
+ IBAR = 0
+ RETURN
+ ENDIF
+
+ IF (ID.EQ.0) RETURN
+
+ IDD = IDT_ICIHAD(ID)
+* modification 21.1.01: use intrinsic phojet-functions to determine charge
+* and baryon number
+C IF (IDD.GT.0) THEN
+C IF (MODE.EQ.2) THEN
+C ICH = ICH+IICH(IDD)
+C IBAR = IBAR+IIBAR(IDD)
+C ELSEIF (MODE.EQ.-2) THEN
+C ICH = ICH-IICH(IDD)
+C IBAR = IBAR-IIBAR(IDD)
+C ENDIF
+C ELSE
+C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
+C CALL DT_EVTOUT(4)
+C STOP
+C ENDIF
+ IF (MODE.EQ.2) THEN
+ ICH = ICH+IPHO_CHR3(ID,1)/3
+ IBAR = IBAR+IPHO_BAR3(ID,1)/3
+ ELSEIF (MODE.EQ.-2) THEN
+ ICH = ICH-IPHO_CHR3(ID,1)/3
+ IBAR = IBAR-IPHO_BAR3(ID,1)/3
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+************************************************************************
+* *
+* 4) Transformations *
+* *
+************************************************************************
+*$ CREATE DT_LTINI.FOR
+*COPY DT_LTINI
+*
+*===ltini==============================================================*
+*
+ SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
+
+************************************************************************
+* Initializations of Lorentz-transformations, calculation of Lorentz- *
+* parameters. *
+* This version dated 13.11.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+ Q2 = VIRT
+ IDP = IDPR
+ IF (MCGENE.NE.3) THEN
+* lepton-projectiles and PHOJET: initialize real photon instead
+ IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
+ & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
+ & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
+ IDP = 7
+ Q2 = ZERO
+ ENDIF
+ ENDIF
+ IDT = IDTA
+ EPN = EPN0
+ PPN = PPN0
+ ECM = ECM0
+ AMP = AAM(IDP)-SQRT(ABS(Q2))
+ AMT = AAM(IDT)
+ AMP2 = SIGN(AMP**2,AMP)
+ AMT2 = AMT**2
+ IF (ECM0.GT.ZERO) THEN
+ EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
+ IF (AMP2.GT.ZERO) THEN
+ PPN = SQRT((EPN+AMP)*(EPN-AMP))
+ ELSE
+ PPN = SQRT(EPN**2-AMP2)
+ ENDIF
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ IF (IDP.EQ.7) EPN = ABS(EPN)
+ IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
+ IF (AMP2.GT.ZERO) THEN
+ PPN = SQRT((EPN+AMP)*(EPN-AMP))
+ ELSE
+ PPN = SQRT(EPN**2-AMP2)
+ ENDIF
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ IF (AMP2.GT.ZERO) THEN
+ EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
+ ELSE
+ EPN = SQRT(PPN**2+AMP2)
+ ENDIF
+ ENDIF
+ ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
+ ENDIF
+ UMO = ECM
+ EPROJ = EPN
+ PPROJ = PPN
+ IF (AMP2.GT.ZERO) THEN
+ ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
+ PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
+ ELSE
+ ETARG = TINY10
+ PTARG = TINY10
+ ENDIF
+* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
+ IF (IDP.EQ.7) THEN
+ PGAMM(1) = ZERO
+ PGAMM(2) = ZERO
+ AMGAM = AMP
+ AMGAM2 = AMP2
+ IF (ECM0.GT.ZERO) THEN
+ S = ECM0**2
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
+ ENDIF
+ ENDIF
+ PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
+ & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
+ PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
+ IF (MODE.EQ.1) THEN
+ PNUCL(1) = ZERO
+ PNUCL(2) = ZERO
+ PNUCL(3) = -PGAMM(3)
+ PNUCL(4) = SQRT(S)-PGAMM(4)
+ ENDIF
+ ENDIF
+ IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
+ & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
+ PLEPT0(1) = ZERO
+ PLEPT0(2) = ZERO
+* neglect lepton masses
+C AMLPT2 = AAM(IDPR)**2
+ AMLPT2 = ZERO
+*
+ IF (ECM0.GT.ZERO) THEN
+ S = ECM0**2
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
+ ENDIF
+ ENDIF
+ PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
+ & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
+ PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
+ PNUCL(1) = ZERO
+ PNUCL(2) = ZERO
+ PNUCL(3) = -PLEPT0(3)
+ PNUCL(4) = SQRT(S)-PLEPT0(4)
+ ENDIF
+* Lorentz-parameter for transformation Lab. - projectile rest system
+ IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
+ GALAB = TINY10
+ BGLAB = TINY10
+ BLAB = TINY10
+ ELSE
+ GALAB = EPROJ/AMP
+ BGLAB = PPROJ/AMP
+ BLAB = BGLAB/GALAB
+ ENDIF
+* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
+ IF (IDP.EQ.7) THEN
+ GACMS(1) = TINY10
+ BGCMS(1) = TINY10
+ ELSE
+ GACMS(1) = (ETARG+AMP)/UMO
+ BGCMS(1) = PTARG/UMO
+ ENDIF
+* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
+ GACMS(2) = (EPROJ+AMT)/UMO
+ BGCMS(2) = PPROJ/UMO
+ PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
+
+ EPN0 = EPN
+ PPN0 = PPN
+ ECM0 = ECM
+
+ RETURN
+ END
+
+*$ CREATE DT_LTRANS.FOR
+*COPY DT_LTRANS
+*
+*===ltrans=============================================================*
+*
+ SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
+
+************************************************************************
+* Lorentz-transformations. *
+* MODE = 1(-1) projectile rest syst. --> Lab (back) *
+* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
+* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
+* This version dated 01.11.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
+
+ PARAMETER (SQTINF=1.0D+15)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ PXO = PXI
+ PYO = PYI
+ CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
+
+* check particle mass for consistency (numerical rounding errors)
+ PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
+ AMO2 = (PEO-PO)*(PEO+PO)
+ AMORQ2 = AAM(ID)**2
+ AMDIF2 = ABS(AMO2-AMORQ2)
+ IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
+ DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
+ PEO = PEO+DELTA
+ PO1 = PO -DELTA
+ PXO = PXO*PO1/PO
+ PYO = PYO*PO1/PO
+ PZO = PZO*PO1/PO
+C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_LTNUC.FOR
+*COPY DT_LTNUC
+*
+*===ltnuc==============================================================*
+*
+ SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
+
+************************************************************************
+* Lorentz-transformations. *
+* PIN longitudnal momentum (input) *
+* EIN energy (input) *
+* POUT transformed long. momentum (output) *
+* EOUT transformed energy (output) *
+* MODE = 1(-1) projectile rest syst. --> Lab (back) *
+* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
+* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
+* This version dated 01.11.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+ BDUM1 = ZERO
+ BDUM2 = ZERO
+ PDUM1 = ZERO
+ PDUM2 = ZERO
+ IF (ABS(MODE).EQ.1) THEN
+ BG = -SIGN(BGLAB,DBLE(MODE))
+ CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSEIF (ABS(MODE).EQ.2) THEN
+ BG = SIGN(BGCMS(1),DBLE(MODE))
+ CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSEIF (ABS(MODE).EQ.3) THEN
+ BG = -SIGN(BGCMS(2),DBLE(MODE))
+ CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSE
+ WRITE(LOUT,1000) MODE
+ 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
+ EOUT = EIN
+ POUT = PIN
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_DALTRA.FOR
+*COPY DT_DALTRA
+*
+*===daltra=============================================================*
+*
+ SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
+
+************************************************************************
+* Arbitrary Lorentz-transformation. *
+* Adopted from the original by S. Roesler. This version dated 15.01.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ EP = PCX*BGX+PCY*BGY+PCZ*BGZ
+ PE = EP/(GA+ONE)+EC
+ PX = PCX+BGX*PE
+ PY = PCY+BGY*PE
+ PZ = PCZ+BGZ*PE
+ P = SQRT(PX*PX+PY*PY+PZ*PZ)
+ E = GA*EC+EP
+
+ RETURN
+ END
+
+*$ CREATE DT_DTRAFO.FOR
+*COPY DT_DTRAFO
+*
+*====dtrafo============================================================*
+*
+ SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
+ & PL,CXL,CYL,CZL,EL)
+
+C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
+ SID = SQRT(1.D0-COD*COD)
+ PLX = P*SID*COF
+ PLY = P*SID*SIF
+ PCMZ = P*COD
+ PLZ = GAM*PCMZ+BGAM*ECM
+ PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
+ EL = GAM*ECM+BGAM*PCMZ
+C ROTATION INTO THE ORIGINAL DIRECTION
+ COZ = PLZ/PL
+ SIZ = SQRT(1.D0-COZ**2)
+ CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
+
+ RETURN
+ END
+
+*$ CREATE DT_STTRAN.FOR
+*COPY DT_STTRAN
+*
+*====sttran============================================================*
+*
+ SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ DATA ANGLSQ/1.D-30/
+************************************************************************
+* VERSION BY J. RANFT *
+* LEIPZIG *
+* *
+* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
+* *
+* INPUT VARIABLES: *
+* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
+* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
+* ANGLE OF "SCATTERING" *
+* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
+* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
+* OF "SCATTERING" *
+* *
+* OUTPUT VARIABLES: *
+* X,Y,Z = NEW DIRECTION COSINES *
+* *
+* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
+************************************************************************
+*
+*
+* Changed by A. Ferrari
+*
+* IF (ABS(XO)-0.0001D0) 1,1,2
+* 1 IF (ABS(YO)-0.0001D0) 3,3,2
+* 3 CONTINUE
+ A = XO**2 + YO**2
+ IF ( A .LT. ANGLSQ ) THEN
+ X=SDE*CFE
+ Y=SDE*SFE
+ Z=CDE*ZO
+ ELSE
+ XI=SDE*CFE
+ YI=SDE*SFE
+ ZI=CDE
+ A=SQRT(A)
+ X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
+ Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
+ Z=A*YI+ZO*ZI
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_MYTRAN.FOR
+*COPY DT_MYTRAN
+*
+*===mytran=============================================================*
+*
+ SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+
+************************************************************************
+* This subroutine rotates the coordinate frame *
+* a) theta around y *
+* b) phi around z if IMODE = 1 *
+* *
+* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
+* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
+* z' 0 0 1 -sin(th) 0 cos(th) z *
+* *
+* and vice versa if IMODE = 0. *
+* This version dated 5.4.94 is based on the original version DTRAN *
+* by J. Ranft and is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ IF (IMODE.EQ.1) THEN
+ X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
+ Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
+ Z=-SDE *XO +CDE *ZO
+ ELSE
+ X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
+ Y= -SFE*XO+CFE*YO
+ Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
+ ENDIF
+ RETURN
+ END
+
+*$ CREATE DT_LT2LAO.FOR
+*COPY DT_LT2LAO
+*
+*===lt2lab=============================================================*
+*
+ SUBROUTINE DT_LT2LAO
+
+************************************************************************
+* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
+* for final state particles/fragments defined in nucleon-nucleon-cms *
+* and transforms them back to the lab. *
+* This version dated 16.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ NEND = NHKK
+ NPOINT(5) = NHKK+1
+ IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
+ DO 1 I=NPOINT(4),NEND
+C DO 1 I=1,NEND
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
+ NOB = NOBAM(I)
+ CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
+ & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
+ IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
+ ISTHKK(I) = 3*ISTHKK(I)
+ NOBAM(NHKK) = NOB
+ ELSE
+ IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
+ ISTHKK(I) = SIGN(3,ISTHKK(I))
+ ENDIF
+ JDAHKK(1,I) = NHKK
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_LT2LAB.FOR
+*COPY DT_LT2LAB
+*
+*===lt2lab=============================================================*
+*
+ SUBROUTINE DT_LT2LAB
+
+************************************************************************
+* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
+* for final state particles/fragments defined in nucleon-nucleon-cms *
+* and transforms them to the lab. *
+* This version dated 07.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+ DO 1 I=NPOINT(4),NHKK
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
+ PHKK(3,I) = PZ
+ PHKK(4,I) = PE
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 5) Sampling from distributions *
+* *
+************************************************************************
+*$ CREATE IDT_NPOISS.FOR
+*COPY IDT_NPOISS
+*
+*===npoiss=============================================================*
+*
+ INTEGER FUNCTION IDT_NPOISS(AVN)
+
+************************************************************************
+* Sample according to Poisson distribution with Poisson parameter AVN. *
+* The original version written by J. Ranft. *
+* This version dated 11.1.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ EXPAVN = EXP(-AVN)
+ K = 1
+ A = 1.0D0
+
+ 10 CONTINUE
+ A = DT_RNDM(A)*A
+ IF (A.GE.EXPAVN) THEN
+ K = K+1
+ GOTO 10
+ ENDIF
+ IDT_NPOISS = K-1
+
+ RETURN
+ END
+
+*$ CREATE DT_SAMPXB.FOR
+*COPY DT_SAMPXB
+*
+*===sampxb=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
+
+************************************************************************
+* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0)
+
+ A1 = LOG(X1+SQRT(X1**2+B**2))
+ A2 = LOG(X2+SQRT(X2**2+B**2))
+ AN = A2-A1
+ A = AN*DT_RNDM(A1)+A1
+ BB = EXP(A)
+ DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
+
+ RETURN
+ END
+
+*$ CREATE DT_SAMPEX.FOR
+*COPY DT_SAMPEX
+*
+*===sampex=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
+
+************************************************************************
+* Sampling from f(x)=1./x between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(X1)
+ AL1 = LOG(X1)
+ AL2 = LOG(X2)
+ DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
+
+ RETURN
+ END
+
+*$ CREATE DT_SAMSQX.FOR
+*COPY DT_SAMSQX
+*
+*===samsqx=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
+
+************************************************************************
+* Sampling from f(x)=1./x^0.5 between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(X1)
+ DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
+
+ RETURN
+ END
+
+*$ CREATE DT_SAMPLW.FOR
+*COPY DT_SAMPLW
+*
+*===samplw=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
+
+************************************************************************
+* Sampling from f(x)=1/x^b between x_min and x_max. *
+* S. Roesler, 18.4.98 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(B)
+ IF (B.EQ.ONE) THEN
+ DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
+ ELSE
+ ONEMB = ONE-B
+ DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_BETREJ.FOR
+*COPY DT_BETREJ
+*
+*===betrej=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ONE=1.0D0)
+
+ IF (XMIN.GE.XMAX)THEN
+ WRITE (LOUT,500) XMIN,XMAX
+ 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
+ STOP
+ ENDIF
+
+ 10 CONTINUE
+ XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
+ BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
+ YY = BETMAX*DT_RNDM(XX)
+ BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
+ IF (YY.GT.BETXX) GOTO 10
+ DT_BETREJ = XX
+
+ RETURN
+ END
+
+*$ CREATE DT_DGAMRN.FOR
+*COPY DT_DGAMRN
+*
+*===dgamrn=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
+
+************************************************************************
+* Sampling from Gamma-distribution. *
+* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
+
+ NCOU = 0
+ N = INT(ETA)
+ F = ETA-DBLE(N)
+ IF (F.EQ.ZERO) GOTO 20
+ 10 R = DT_RNDM(F)
+ NCOU = NCOU+1
+ IF (NCOU.GE.11) GOTO 20
+ IF (R.LT.F/(F+2.71828D0)) GOTO 30
+ YYY = LOG(DT_RNDM(R)+TINY9)/F
+ IF (ABS(YYY).GT.50.0D0) GOTO 20
+ Y = EXP(YYY)
+ IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
+ GOTO 40
+ 20 Y = 0.0D0
+ GOTO 50
+ 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
+ IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
+ 40 IF (N.EQ.0) GOTO 70
+ 50 Z = 1.0D0
+ DO 60 I = 1,N
+ 60 Z = Z*DT_RNDM(Z)
+ Y = Y-LOG(Z+TINY9)
+ 70 DT_DGAMRN = Y/ALAM
+
+ RETURN
+ END
+
+*$ CREATE DT_DBETAR.FOR
+*COPY DT_DBETAR
+*
+*===dbetar=============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
+
+************************************************************************
+* Sampling from Beta -distribution between 0.0 and 1.0 *
+* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ Y = DT_DGAMRN(1.0D0,GAM)
+ Z = DT_DGAMRN(1.0D0,ETA)
+ DT_DBETAR = Y/(Y+Z)
+
+ RETURN
+ END
+
+*$ CREATE DT_RANNOR.FOR
+*COPY DT_RANNOR
+*
+*===rannor=============================================================*
+*
+ SUBROUTINE DT_RANNOR(X,Y)
+
+************************************************************************
+* Sampling from Gaussian distribution. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TINY10=1.0D-10)
+
+ CALL DT_DSFECF(SFE,CFE)
+ V = MAX(TINY10,DT_RNDM(X))
+ A = SQRT(-2.D0*LOG(V))
+ X = A*SFE
+ Y = A*CFE
+
+ RETURN
+ END
+
+*$ CREATE DT_DPOLI.FOR
+*COPY DT_DPOLI
+*
+*===dpoli==============================================================*
+*
+ SUBROUTINE DT_DPOLI(CS,SI)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ U = DT_RNDM(CS)
+ CS = DT_RNDM(U)
+ IF (U.LT.0.5D0) CS=-CS
+ SI = SQRT(1.0D0-CS*CS+1.0D-10)
+
+ RETURN
+ END
+
+*$ CREATE DT_DSFECF.FOR
+*COPY DT_DSFECF
+*
+*===dsfecf=============================================================*
+*
+ SUBROUTINE DT_DSFECF(SFE,CFE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
+
+ 1 CONTINUE
+ X = DT_RNDM(SFE)
+ Y = DT_RNDM(X)
+ XX = X*X
+ YY = Y*Y
+ XY = XX+YY
+ IF (XY.GT.ONE) GOTO 1
+ CFE = (XX-YY)/XY
+ SFE = TWO*X*Y/XY
+ IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
+ RETURN
+ END
+
+*$ CREATE DT_RACO.FOR
+*COPY DT_RACO
+*
+*===raco===============================================================*
+*
+ SUBROUTINE DT_RACO(WX,WY,WZ)
+
+************************************************************************
+* Direction cosines of random uniform (isotropic) direction in three *
+* dimensional space *
+* Processed by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
+
+ 10 CONTINUE
+ X = TWO*DT_RNDM(WX)-ONE
+ Y = DT_RNDM(X)
+ X2 = X*X
+ Y2 = Y*Y
+ IF (X2+Y2.GT.ONE) GOTO 10
+
+ CFE = (X2-Y2)/(X2+Y2)
+ SFE = TWO*X*Y/(X2+Y2)
+* z = 1/2 [ 1 + cos (theta) ]
+ Z = DT_RNDM(X)
+* 1/2 sin (theta)
+ WZ = SQRT(Z*(ONE-Z))
+ WX = TWO*WZ*CFE
+ WY = TWO*WZ*SFE
+ WZ = TWO*Z-ONE
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 6) Special functions, algorithms and service routines *
+* *
+************************************************************************
+*$ CREATE DT_YLAMB.FOR
+*COPY DT_YLAMB
+*
+*===ylamb==============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
+
+************************************************************************
+* *
+* auxiliary function for three particle decay mode *
+* (standard LAMBDA**(1/2) function) *
+* *
+* Adopted from an original version written by R. Engel. *
+* This version dated 12.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ YZ = Y-Z
+ XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
+ IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
+ DT_YLAMB = SQRT(XLAM)
+
+ RETURN
+ END
+
+*$ CREATE DT_SORT.FOR
+*COPY DT_SORT
+*
+*===sort1==============================================================*
+*
+ SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
+
+************************************************************************
+* This subroutine sorts entries in A in increasing/decreasing order *
+* of A(3,i). *
+* MODE = 1 increasing in A(3,i=1..N) *
+* = 2 decreasing in A(3,i=1..N) *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION A(3,N)
+
+ M = I1
+ 10 CONTINUE
+ M = I1-1
+ IF (M.LE.0) RETURN
+ L = 0
+ DO 20 I=I0,M
+ J = I+1
+ IF (MODE.EQ.1) THEN
+ IF (A(3,I).LE.A(3,J)) GOTO 20
+ ELSE
+ IF (A(3,I).GE.A(3,J)) GOTO 20
+ ENDIF
+ B = A(3,I)
+ C = A(1,I)
+ D = A(2,I)
+ A(3,I) = A(3,J)
+ A(2,I) = A(2,J)
+ A(1,I) = A(1,J)
+ A(3,J) = B
+ A(1,J) = C
+ A(2,J) = D
+ L = 1
+ 20 CONTINUE
+ IF (L.EQ.1) GOTO 10
+
+ RETURN
+ END
+
+*$ CREATE DT_SORT1.FOR
+*COPY DT_SORT1
+*
+*===sort1==============================================================*
+*
+ SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
+
+************************************************************************
+* This subroutine sorts entries in A in increasing/decreasing order *
+* of A(i). *
+* MODE = 1 increasing in A(i=1..N) *
+* = 2 decreasing in A(i=1..N) *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION A(N),IDX(N)
+
+ M = I1
+ 10 CONTINUE
+ M = I1-1
+ IF (M.LE.0) RETURN
+ L = 0
+ DO 20 I=I0,M
+ J = I+1
+ IF (MODE.EQ.1) THEN
+ IF (A(I).LE.A(J)) GOTO 20
+ ELSE
+ IF (A(I).GE.A(J)) GOTO 20
+ ENDIF
+ B = A(I)
+ A(I) = A(J)
+ A(J) = B
+ IX = IDX(I)
+ IDX(I) = IDX(J)
+ IDX(J) = IX
+ L = 1
+ 20 CONTINUE
+ IF (L.EQ.1) GOTO 10
+
+ RETURN
+ END
+
+*$ CREATE DT_XTIME.FOR
+*COPY DT_XTIME
+*
+*===xtime==============================================================*
+*
+ SUBROUTINE DT_XTIME
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER DAT*9,TIM*11
+
+ DAT = ' '
+ TIM = ' '
+C CALL GETDAT(IYEAR,IMONTH,IDAY)
+C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
+
+C CALL DATE(DAT)
+C CALL TIME(TIM)
+C WRITE(LOUT,1000) DAT,TIM
+ 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 7) Random number generator package *
+* *
+* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
+* SERVICE ROUTINES. *
+* THE ALGORITHM IS FROM *
+* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
+* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
+* IMPLEMENTATION BY K. HAHN DEC. 88, *
+* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
+* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
+* THE PERIOD IS ABOUT 2**144, *
+* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
+* THE PACKAGE CONTAINS *
+* FUNCTION DT_RNDM(I) : GENERATOR *
+* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
+* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
+* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
+* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
+*--- *
+* FUNCTION DT_RNDM(I) *
+* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
+* I - DUMMY VARIABLE, NOT USED *
+* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
+* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
+* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
+* NA? MUST BE IN 1..178 AND NOT ALL 1 *
+* 12,34,56 ARE THE STANDARD VALUES *
+* NB1 MUST BE IN 1..168 *
+* 78 IS THE STANDARD VALUE *
+* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
+* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
+* AS AFTER THE LAST DT_RNDMOU CALL ) *
+* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
+* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
+* TAKES SEED FROM GENERATOR *
+* U(97),C,CD,CM,I,J - SEED VALUES *
+* SUBROUTINE DT_RNDMTE(IO) *
+* TEST OF THE GENERATOR *
+* IO - DEFINES OUTPUT *
+* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
+* = 1 OUTPUT INDEPENDEND ON AN ERROR *
+* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
+* SAME STATUS *
+* AS BEFORE CALL OF DT_RNDMTE *
+************************************************************************
+*$ CREATE DT_RNDM.FOR
+*COPY DT_RNDM
+*
+*===rndm===============================================================*
+*
+c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
+c$$$
+c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c$$$ SAVE
+c$$$
+c$$$* counter of calls to random number generator
+c$$$* uncomment if needed
+c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
+c$$$C LOGICAL LFIRST
+c$$$C DATA LFIRST /.TRUE./
+c$$$
+c$$$* counter of calls to random number generator
+c$$$* uncomment if needed
+c$$$C IF (LFIRST) THEN
+c$$$C IRNCT0 = 0
+c$$$C IRNCT1 = 0
+c$$$C LFIRST = .FALSE.
+c$$$C ENDIF
+c$$$
+c$$$ DT_RNDM = FLRNDM(VDUMMY)
+c$$$* counter of calls to random number generator
+c$$$* uncomment if needed
+c$$$C IRNCT1 = IRNCT1+1
+c$$$
+c$$$ RETURN
+c$$$ END
+c$$$
+c$$$*$ CREATE DT_RNDMST.FOR
+c$$$*COPY DT_RNDMST
+c$$$*
+c$$$*===rndmst=============================================================*
+c$$$*
+c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
+c$$$
+c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c$$$ SAVE
+c$$$
+c$$$* random number generator
+c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+c$$$
+c$$$ MA1 = NA1
+c$$$ MA2 = NA2
+c$$$ MA3 = NA3
+c$$$ MB1 = NB1
+c$$$ I = 97
+c$$$ J = 33
+c$$$ DO 20 II2 = 1,97
+c$$$ S = 0
+c$$$ T = 0.5D0
+c$$$ DO 10 II1 = 1,24
+c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
+c$$$ MA1 = MA2
+c$$$ MA2 = MA3
+c$$$ MA3 = MAT
+c$$$ MB1 = MOD(53*MB1+1,169)
+c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
+c$$$ 10 T = 0.5D0*T
+c$$$ 20 U(II2) = S
+c$$$ C = 362436.0D0/16777216.0D0
+c$$$ CD = 7654321.0D0/16777216.0D0
+c$$$ CM = 16777213.0D0/16777216.0D0
+c$$$ RETURN
+c$$$ END
+c$$$
+c$$$*$ CREATE DT_RNDMIN.FOR
+c$$$*COPY DT_RNDMIN
+c$$$*
+c$$$*===rndmin=============================================================*
+c$$$*
+c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
+c$$$
+c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c$$$ SAVE
+c$$$
+c$$$* random number generator
+c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+c$$$
+c$$$ DIMENSION UIN(97)
+c$$$
+c$$$ DO 10 KKK = 1,97
+c$$$ 10 U(KKK) = UIN(KKK)
+c$$$ C = CIN
+c$$$ CD = CDIN
+c$$$ CM = CMIN
+c$$$ I = IIN
+c$$$ J = JIN
+c$$$
+c$$$ RETURN
+c$$$ END
+c$$$
+c$$$*$ CREATE DT_RNDMOU.FOR
+c$$$*COPY DT_RNDMOU
+c$$$*
+c$$$*===rndmou=============================================================*
+c$$$*
+c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
+c$$$
+c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c$$$ SAVE
+c$$$
+c$$$* random number generator
+c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+c$$$
+c$$$ DIMENSION UOUT(97)
+c$$$
+c$$$ DO 10 KKK = 1,97
+c$$$ 10 UOUT(KKK) = U(KKK)
+c$$$ COUT = C
+c$$$ CDOUT = CD
+c$$$ CMOUT = CM
+c$$$ IOUT = I
+c$$$ JOUT = J
+c$$$
+c$$$ RETURN
+c$$$ END
+c$$$
+c$$$*$ CREATE DT_RNDMTE.FOR
+c$$$*COPY DT_RNDMTE
+c$$$*
+c$$$*===rndmte=============================================================*
+c$$$*
+c$$$ SUBROUTINE DT_RNDMTE(IO)
+c$$$
+c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c$$$ SAVE
+c$$$
+c$$$ DIMENSION UU(97),U(6),X(6),D(6)
+c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
+c$$$ +8354498.D0, 10633180.D0/
+c$$$
+c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
+c$$$ CALL DT_RNDMST(12,34,56,78)
+c$$$ DO 10 II1 = 1,20000
+c$$$ 10 XX = DT_RNDM(XX)
+c$$$ SD = 0.0D0
+c$$$ DO 20 II2 = 1,6
+c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
+c$$$ D(II2) = X(II2)-U(II2)
+c$$$ 20 SD = SD+D(II2)
+c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
+c$$$**sr 24.01.95
+c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
+c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
+c$$$C WRITE(6,1000)
+c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
+c$$$ & ' passed')
+c$$$ ENDIF
+c$$$**
+c$$$ RETURN
+c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
+c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
+c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
+c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
+c$$$ END
+*
+*$ CREATE PHO_RNDM.FOR
+*COPY PHO_RNDM
+*
+*===pho_rndm===========================================================*
+*
+ DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PHO_RNDM = DT_RNDM(DUMMY)
+
+ RETURN
+ END
+
+*$ CREATE PYR.FOR
+*COPY PYR
+*
+*===pyr================================================================*
+*
+ DOUBLE PRECISION FUNCTION PYR(IDUMMY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DUMMY = DBLE(IDUMMY)
+ PYR = DT_RNDM(DUMMY)
+
+ RETURN
+ END
+*$ CREATE DT_TITLE.FOR
+*COPY DT_TITLE
+*
+*===title==============================================================*
+*
+ SUBROUTINE DT_TITLE
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*6 CVERSI
+ CHARACTER*11 CCHANG
+ DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
+
+ CALL DT_XTIME
+ WRITE(LOUT,1000) CVERSI,CCHANG
+ 1000 FORMAT(1X,'+-------------------------------------------------',
+ & '----------------------+',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
+ & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
+ & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
+C & 1X,'|',71X,'|',/,
+C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
+C & 17X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'+-------------------------------------------------',
+ & '----------------------+',/,
+ & 1X,'| Please send suggestions, bug reports, etc. to: ',
+ & 'Stefan.Roesler@cern.ch |',/,
+ & 1X,'+-------------------------------------------------',
+ & '----------------------+',/)
+
+ RETURN
+ END
+
+*$ CREATE DT_EVTINI.FOR
+*COPY DT_EVTINI
+*
+*===evtini=============================================================*
+*
+ SUBROUTINE DT_EVTINI
+
+************************************************************************
+* Initialization of DTEVT1. *
+* This version dated 15.01.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* initialization of DTEVT1/DTEVT2
+ NEND = NHKK
+ IF (NEVENT.EQ.1) NEND = NMXHKK
+ NHKK = 0
+ NEVHKK = NEVENT
+ DO 1 I=1,NEND
+ ISTHKK(I) = 0
+ IDHKK(I) = 0
+ JMOHKK(1,I) = 0
+ JMOHKK(2,I) = 0
+ JDAHKK(1,I) = 0
+ JDAHKK(2,I) = 0
+ IDRES(I) = 0
+ IDXRES(I) = 0
+ NOBAM(I) = 0
+ IDCH(I) = 0
+ IHIST(1,I) = 0
+ IHIST(2,I) = 0
+ DO 2 J=1,4
+ PHKK(J,I) = 0.0D0
+ VHKK(J,I) = 0.0D0
+ WHKK(J,I) = 0.0D0
+ 2 CONTINUE
+ PHKK(5,I) = 0.0D0
+ 1 CONTINUE
+ DO 3 I=1,10
+ NPOINT(I) = 0
+ 3 CONTINUE
+ CALL DT_CHASTA(-1)
+
+C* initialization of DTLTRA
+C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
+
+ RETURN
+ END
+
+*$ CREATE DT_STATIS.FOR
+*COPY DT_STATIS
+*
+*===statis=============================================================*
+*
+ SUBROUTINE DT_STATIS(MODE)
+
+************************************************************************
+* Initialization and output of run-statistics. *
+* MODE = 1 initialization *
+* = 2 output *
+* This version dated 23.01.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY3=1.0D-3)
+
+* statistics
+ COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+ & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+ & ICEVTG(8,0:30)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+ LOGICAL LCO2CR,LINTPT
+ COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+ & LCO2CR,LINTPT
+
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+ DIMENSION PP(4),PT(4)
+
+ GOTO (1,2) MODE
+
+* initialization
+ 1 CONTINUE
+
+* initialize statistics counter
+ ICREQU = 0
+ ICSAMP = 0
+ ICCPRO = 0
+ ICDPR = 0
+ ICDTA = 0
+ ICRJSS = 0
+ ICVV2S = 0
+ DO 10 I=1,9
+ ICRES(I) = 0
+ ICCHAI(1,I) = 0
+ ICCHAI(2,I) = 0
+ 10 CONTINUE
+* initialize rejection counter
+ IRPT = 0
+ IRHHA = 0
+ LOMRES = 0
+ LOBRES = 0
+ IRFRAG = 0
+ IREVT = 0
+ IRRES(1) = 0
+ IRRES(2) = 0
+ IRCHKI(1) = 0
+ IRCHKI(2) = 0
+ IRCRON(1) = 0
+ IRCRON(2) = 0
+ IRCRON(3) = 0
+ IRDIFF(1) = 0
+ IRDIFF(2) = 0
+ IRINC = 0
+ DO 11 I=1,5
+ ICDIFF(I) = 0
+ 11 CONTINUE
+ DO 12 I=1,8
+ DO 13 J=0,30
+ ICEVTG(I,J) = 0
+ 13 CONTINUE
+ 12 CONTINUE
+
+ RETURN
+
+* output
+ 2 CONTINUE
+
+* statistics counter
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
+ & 28X,'---------------------')
+ WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
+ 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
+ & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
+ & 'event',11X,F9.1)
+ IF (ICDIFF(1).NE.0) THEN
+ WRITE(LOUT,1009) ICDIFF
+ 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
+ & 'low mass high mass',/,24X,'single diffraction',
+ & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
+ ENDIF
+ IF (ICENTR.GT.0) THEN
+ WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
+ & DBLE(ICSAMP)/DBLE(ICCPRO)
+ 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
+ & ' of sampled Glauber-events per event',9X,F9.1,/,
+ & 2X,'fraction of production cross section',21X,F10.6)
+ ENDIF
+ WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
+ & DBLE(ICDTA)/DBLE(ICSAMP)
+ 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
+ & ' nucleons after x-sampling',2(4X,F6.2))
+
+ IF (MCGENE.EQ.1) THEN
+ WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
+ 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
+ & ' event',3X,F9.1)
+ IF (ISICHA.EQ.1) THEN
+ WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
+ 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
+ & 'of single chains per event',13X,F9.1)
+ ENDIF
+ WRITE(LOUT,1006)
+ 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
+ & 23X,'mean number of chains mean number of chains',/,
+ & 23X,'sampled hadronized having mass of a reso.')
+ WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
+ & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
+ & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
+ & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
+ 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
+ WRITE(LOUT,1008)
+ & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
+ & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
+ & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
+ & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
+ & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
+ & DBLE(IRHHA)/DBLE(ICREQU),
+ & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
+ & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
+ 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
+ & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
+ & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
+ & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
+ & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
+ & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
+ & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
+ & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
+ & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
+ & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
+ & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
+ & F7.2,/,1X,'Total no. of rej.',
+ & ' in chain-systems treatment (GETCSY)',/,43X,
+ & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
+ & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
+ & 1X,'Total no. of rej. in DPM-treatment of one event',
+ & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
+ & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
+ & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
+ & 'IREXCI(3) = ',I5,/)
+ ELSEIF (MCGENE.EQ.2) THEN
+ WRITE(LOUT,1010) ELOJET
+ 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
+ & F4.1,' GeV')
+ WRITE(LOUT,1011)
+ 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
+ & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
+ & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
+ WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
+ & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
+ & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
+ & ((ICEVTG(I,J),I=1,8),J=3,7),
+ & ((ICEVTG(I,J),I=1,8),J=19,21),
+ & (ICEVTG(I,8),I=1,8),
+ & ((ICEVTG(I,J),I=1,8),J=22,24),
+ & (ICEVTG(I,9),I=1,8),
+ & ((ICEVTG(I,J),I=1,8),J=25,28),
+ & ((ICEVTG(I,J),I=1,8),J=10,18)
+ 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
+ & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
+ & ' no-dif.',8I8,/,
+ & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
+ & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
+ & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
+ & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
+ & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
+ & ' hi-lo ',8I8,/,
+ & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
+ & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
+ & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
+ WRITE(LOUT,1013)
+ 1013 FORMAT(/,1X,'2. chain system statistics -',
+ & ' mean numbers per evt:',/,30X,'---------------------',
+ & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
+ WRITE(LOUT,1014)
+ & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
+ & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
+ & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
+ 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
+ & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
+ & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
+ & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
+ & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
+ & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
+ & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
+ & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
+ & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
+ & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
+ WRITE(LOUT,1015)
+ 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
+ WRITE(LOUT,1016)
+ & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
+ & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
+ & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
+ 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
+ & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
+ & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
+ & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
+ & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
+ & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
+ & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
+ & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
+ & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
+ & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
+
+ ENDIF
+ CALL DT_CHASTA(1)
+
+ IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
+ & .OR.(PDBSEA(3).GT.0.0D0)) THEN
+ WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
+ & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
+ & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
+ WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
+ & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
+ & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
+ WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
+ & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
+ & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
+ WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
+ & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
+ & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
+ WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
+ & DBRKA(3,1),DBRKA(3,2),
+ & DBRKA(3,3),DBRKA(3,4)
+ WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
+ & DBRKR(3,1),DBRKR(3,2),
+ & DBRKR(3,3),DBRKR(3,4)
+ WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
+ & DBRKA(3,5),DBRKA(3,6),
+ & DBRKA(3,7),DBRKA(3,8)
+ WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
+ & DBRKR(3,5),DBRKR(3,6),
+ & DBRKR(3,7),DBRKR(3,8)
+ ENDIF
+
+ FAC = 1.0D0
+ IF (MCGENE.EQ.2) THEN
+
+C CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
+
+ ENDIF
+
+ CALL DT_XTIME
+
+ RETURN
+ END
+
+*$ CREATE DT_EVTOUT.FOR
+*COPY DT_EVTOUT
+*
+*===evtout=============================================================*
+*
+ SUBROUTINE DT_EVTOUT(MODE)
+
+************************************************************************
+* MODE = 1 plot content of complete DTEVT1 to out. unit *
+* 3 plot entries of extended DTEVT1 (DTEVT2) *
+* 4 plot entries of DTEVT1 and DTEVT2 *
+* This version dated 11.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+ DIMENSION IRANGE(NMXHKK)
+
+ IF (MODE.EQ.2) RETURN
+
+ CALL DT_EVTPLO(IRANGE,MODE)
+
+ RETURN
+ END
+
+*$ CREATE DT_EVTPLO.FOR
+*COPY DT_EVTPLO
+*
+*===evtplo=============================================================*
+*
+ SUBROUTINE DT_EVTPLO(IRANGE,MODE)
+
+************************************************************************
+* MODE = 1 plot content of complete DTEVT1 to out. unit *
+* 2 plot entries of DTEVT1 given by IRANGE *
+* 3 plot entries of extended DTEVT1 (DTEVT2) *
+* 4 plot entries of DTEVT1 and DTEVT2 *
+* 5 plot rejection counter *
+* This version dated 11.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*16 CHAU
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+ DIMENSION IRANGE(NMXHKK)
+
+ IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
+ & 15X,' --------------------------',/,/,
+ & ' ST ID M1 M2 D1 D2 PX PY',
+ & ' PZ E M',/)
+ DO 1 I=1,NHKK
+ WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PHKK(5,I)
+C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+C & PHKK(3,I),PHKK(4,I)
+C WRITE(LOUT,'(4E15.4)')
+C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
+ 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
+ 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
+ 1 CONTINUE
+ WRITE(LOUT,*)
+C DO 4 I=1,NHKK
+C WRITE(LOUT,1006) I,ISTHKK(I),
+C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
+C & WHKK(2,I),WHKK(3,I)
+C1006 FORMAT(1X,I4,I6,6E10.3)
+C 4 CONTINUE
+ ENDIF
+
+ IF (MODE.EQ.2) THEN
+ WRITE(LOUT,1000)
+ NC = 0
+ 2 CONTINUE
+ NC = NC+1
+ IF (IRANGE(NC).EQ.-100) GOTO 9999
+ I = IRANGE(NC)
+ WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PHKK(5,I)
+ GOTO 2
+ ENDIF
+
+ IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
+ WRITE(LOUT,1002)
+ 1002 FORMAT(/,1X,'EVTPLO:',14X,
+ & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
+ & 15X,' -----------------------------------',/,/,
+ & ' ST ID M1 M2 D1 D2 IDR IDXR',
+ & ' NOBAM IDCH M',/)
+ DO 3 I=1,NHKK
+C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
+ KF = IDHKK(I)
+ IDCHK = KF/10000
+ IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
+ & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
+
+ CALL PYNAME(KF,CHAU)
+
+ WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
+ & PHKK(5,I),CHAU
+ 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
+C ENDIF
+ 3 CONTINUE
+ ENDIF
+
+ IF (MODE.EQ.5) THEN
+ WRITE(LOUT,1004)
+ 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
+ & 15X,' --------------------------',/)
+ WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
+ & IRSEA,IRCRON
+ 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
+ & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
+ & 1X,'IREMC = ',10I5,/,
+ & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
+ ENDIF
+
+ 9999 RETURN
+ END
+
+*$ CREATE DT_EVTPUT.FOR
+*COPY DT_EVTPUT
+*
+*===evtput=============================================================*
+*
+ SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
+ & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+C IF (MODE.GT.100) THEN
+C WRITE(LOUT,'(1X,A,I5,A,I5)')
+C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
+C NHKK = NHKK-MODE+100
+C RETURN
+C ENDIF
+ MO1 = M1
+ MO2 = M2
+ NHKK = NHKK+1
+
+ IF (NHKK.GT.NMXHKK) THEN
+ WRITE(LOUT,1000) NHKK
+ 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
+ & '! program execution stopped..')
+ STOP
+ ENDIF
+ IF (M1.LT.0) MO1 = NHKK+M1
+ IF (M2.LT.0) MO2 = NHKK+M2
+ ISTHKK(NHKK) = IST
+ IDHKK(NHKK) = ID
+ JMOHKK(1,NHKK) = MO1
+ JMOHKK(2,NHKK) = MO2
+ JDAHKK(1,NHKK) = 0
+ JDAHKK(2,NHKK) = 0
+ IDRES(NHKK) = IDR
+ IDXRES(NHKK) = IDXR
+ IDCH(NHKK) = IDC
+** here we need to do something..
+ IF (ID.EQ.88888) THEN
+ IDMO1 = ABS(IDHKK(MO1))
+ IDMO2 = ABS(IDHKK(MO2))
+ IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
+ IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
+ IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
+ IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
+ ELSE
+ NOBAM(NHKK) = 0
+ ENDIF
+ IDBAM(NHKK) = IDT_ICIHAD(ID)
+ IF (MO1.GT.0) THEN
+ IF (JDAHKK(1,MO1).NE.0) THEN
+ JDAHKK(2,MO1) = NHKK
+ ELSE
+ JDAHKK(1,MO1) = NHKK
+ ENDIF
+ ENDIF
+ IF (MO2.GT.0) THEN
+ IF (JDAHKK(1,MO2).NE.0) THEN
+ JDAHKK(2,MO2) = NHKK
+ ELSE
+ JDAHKK(1,MO2) = NHKK
+ ENDIF
+ ENDIF
+C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
+C PTOT = SQRT(PX**2+PY**2+PZ**2)
+C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
+C AMRQ = AAM(IDBAM(NHKK))
+C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
+C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
+C & (PTOT.GT.ZERO)) THEN
+C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
+CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
+C E = E+DELTA
+C PTOT1 = PTOT-DELTA
+C PX = PX*PTOT1/PTOT
+C PY = PY*PTOT1/PTOT
+C PZ = PZ*PTOT1/PTOT
+C ENDIF
+C ENDIF
+ PHKK(1,NHKK) = PX
+ PHKK(2,NHKK) = PY
+ PHKK(3,NHKK) = PZ
+ PHKK(4,NHKK) = E
+ PTOT = SQRT( PX**2+PY**2+PZ**2 )
+ IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
+ PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
+ PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
+ ELSE
+ PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
+C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
+C & WRITE(LOUT,'(1X,A,G10.3)')
+C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
+ PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
+ ENDIF
+ IDCHK = ID/10000
+ IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
+* special treatment for chains:
+* z coordinate of chain in Lab = pos. of target nucleon
+* time of chain-creation in Lab = time of passage of projectile
+* nucleus at pos. of taget nucleus
+C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
+C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
+ VHKK(1,NHKK) = VHKK(1,MO2)
+ VHKK(2,NHKK) = VHKK(2,MO2)
+ VHKK(3,NHKK) = VHKK(3,MO2)
+ VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
+C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
+C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
+ WHKK(1,NHKK) = WHKK(1,MO1)
+ WHKK(2,NHKK) = WHKK(2,MO1)
+ WHKK(3,NHKK) = WHKK(3,MO1)
+ WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
+ ELSE
+ IF (MO1.GT.0) THEN
+ DO 1 I=1,4
+ VHKK(I,NHKK) = VHKK(I,MO1)
+ WHKK(I,NHKK) = WHKK(I,MO1)
+ 1 CONTINUE
+ ELSE
+ DO 2 I=1,4
+ VHKK(I,NHKK) = ZERO
+ WHKK(I,NHKK) = ZERO
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_CHASTA.FOR
+*COPY DT_CHASTA
+*
+*===chasta=============================================================*
+*
+ SUBROUTINE DT_CHASTA(MODE)
+
+************************************************************************
+* This subroutine performs CHAin STAtistics and checks sequence of *
+* partons in dtevt1 and sorts them with projectile partons coming *
+* first if necessary. *
+* *
+* This version dated 8.5.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*5 CCHTYP
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
+ PARAMETER (MAXCHN=10000)
+ COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
+
+ DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
+ & CCHTYP(9),ICHSTA(10),ITOT(10)
+ DATA ICHCFG /1800*0/
+ DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
+ DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
+ DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
+ DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
+ DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
+ DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
+ DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
+ & 'ad aq',' d ad','ad d ',' g g '/
+*
+* initialization
+*
+ IF (MODE.EQ.-1) THEN
+ NCHAIN = 0
+*
+* loop over DTEVT1 and analyse chain configurations
+*
+ ELSEIF (MODE.EQ.0) THEN
+ DO 21 IDX=NPOINT(3),NHKK
+ IDCHK = IDHKK(IDX)/10000
+ IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
+ & (IDHKK(IDX).NE.80000).AND.
+ & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
+ IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
+ WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
+ & ' at entry ',IDX
+ GOTO 21
+ ENDIF
+*
+ IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
+ IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
+ IMO1 = IST1/10
+ IMO1 = IST1-10*IMO1
+ IMO2 = IST2/10
+ IMO2 = IST2-10*IMO2
+* swop parton entries if necessary since we need projectile partons
+* to come first in the common
+ IF (IMO1.GT.IMO2) THEN
+ NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
+ DO 22 K=1,NPTN/2
+ I0 = JMOHKK(1,IDX)-1+K
+ I1 = JMOHKK(2,IDX)+1-K
+ ITMP = ISTHKK(I0)
+ ISTHKK(I0) = ISTHKK(I1)
+ ISTHKK(I1) = ITMP
+ ITMP = IDHKK(I0)
+ IDHKK(I0) = IDHKK(I1)
+ IDHKK(I1) = ITMP
+ IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
+ & JDAHKK(1,JMOHKK(1,I0)) = I1
+ IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
+ & JDAHKK(2,JMOHKK(1,I0)) = I1
+ IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
+ & JDAHKK(1,JMOHKK(2,I0)) = I1
+ IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
+ & JDAHKK(2,JMOHKK(2,I0)) = I1
+ IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
+ & JDAHKK(1,JMOHKK(1,I1)) = I0
+ IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
+ & JDAHKK(2,JMOHKK(1,I1)) = I0
+ IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
+ & JDAHKK(1,JMOHKK(2,I1)) = I0
+ IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
+ & JDAHKK(2,JMOHKK(2,I1)) = I0
+ ITMP = JMOHKK(1,I0)
+ JMOHKK(1,I0) = JMOHKK(1,I1)
+ JMOHKK(1,I1) = ITMP
+ ITMP = JMOHKK(2,I0)
+ JMOHKK(2,I0) = JMOHKK(2,I1)
+ JMOHKK(2,I1) = ITMP
+ ITMP = JDAHKK(1,I0)
+ JDAHKK(1,I0) = JDAHKK(1,I1)
+ JDAHKK(1,I1) = ITMP
+ ITMP = JDAHKK(2,I0)
+ JDAHKK(2,I0) = JDAHKK(2,I1)
+ JDAHKK(2,I1) = ITMP
+ DO 23 J=1,4
+ RTMP1 = PHKK(J,I0)
+ RTMP2 = VHKK(J,I0)
+ RTMP3 = WHKK(J,I0)
+ PHKK(J,I0) = PHKK(J,I1)
+ VHKK(J,I0) = VHKK(J,I1)
+ WHKK(J,I0) = WHKK(J,I1)
+ PHKK(J,I1) = RTMP1
+ VHKK(J,I1) = RTMP2
+ WHKK(J,I1) = RTMP3
+ 23 CONTINUE
+ RTMP1 = PHKK(5,I0)
+ PHKK(5,I0) = PHKK(5,I1)
+ PHKK(5,I1) = RTMP1
+ ITMP = IDRES(I0)
+ IDRES(I0) = IDRES(I1)
+ IDRES(I1) = ITMP
+ ITMP = IDXRES(I0)
+ IDXRES(I0) = IDXRES(I1)
+ IDXRES(I1) = ITMP
+ ITMP = NOBAM(I0)
+ NOBAM(I0) = NOBAM(I1)
+ NOBAM(I1) = ITMP
+ ITMP = IDBAM(I0)
+ IDBAM(I0) = IDBAM(I1)
+ IDBAM(I1) = ITMP
+ ITMP = IDCH(I0)
+ IDCH(I0) = IDCH(I1)
+ IDCH(I1) = ITMP
+ ITMP = IHIST(1,I0)
+ IHIST(1,I0) = IHIST(1,I1)
+ IHIST(1,I1) = ITMP
+ ITMP = IHIST(2,I0)
+ IHIST(2,I0) = IHIST(2,I1)
+ IHIST(2,I1) = ITMP
+ 22 CONTINUE
+ ENDIF
+ IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
+ IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
+*
+* parton 1 (projectile side)
+ IF (IST1.EQ.21) THEN
+ IDX1 = 1
+ ELSEIF (IST1.EQ.22) THEN
+ IDX1 = 2
+ ELSEIF (IST1.EQ.31) THEN
+ IDX1 = 3
+ ELSEIF (IST1.EQ.32) THEN
+ IDX1 = 4
+ ELSEIF (IST1.EQ.41) THEN
+ IDX1 = 5
+ ELSEIF (IST1.EQ.42) THEN
+ IDX1 = 6
+ ELSEIF (IST1.EQ.51) THEN
+ IDX1 = 7
+ ELSEIF (IST1.EQ.52) THEN
+ IDX1 = 8
+ ELSEIF (IST1.EQ.61) THEN
+ IDX1 = 9
+ ELSEIF (IST1.EQ.62) THEN
+ IDX1 = 10
+ ELSE
+c WRITE(LOUT,*)
+c & ' CHASTA: unknown parton status flag (',
+c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+ ID = IDHKK(JMOHKK(1,IDX))
+ IF (ABS(ID).LE.4) THEN
+ IF (ID.GT.0) THEN
+ ITYP1 = 1
+ ELSE
+ ITYP1 = 2
+ ENDIF
+ ELSEIF (ABS(ID).GE.1000) THEN
+ IF (ID.GT.0) THEN
+ ITYP1 = 3
+ ELSE
+ ITYP1 = 4
+ ENDIF
+ ELSEIF (ID.EQ.21) THEN
+ ITYP1 = 5
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent parton identity (',
+ & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+*
+* parton 2 (target side)
+ IF (IST2.EQ.21) THEN
+ IDX2 = 1
+ ELSEIF (IST2.EQ.22) THEN
+ IDX2 = 2
+ ELSEIF (IST2.EQ.31) THEN
+ IDX2 = 3
+ ELSEIF (IST2.EQ.32) THEN
+ IDX2 = 4
+ ELSEIF (IST2.EQ.41) THEN
+ IDX2 = 5
+ ELSEIF (IST2.EQ.42) THEN
+ IDX2 = 6
+ ELSEIF (IST2.EQ.51) THEN
+ IDX2 = 7
+ ELSEIF (IST2.EQ.52) THEN
+ IDX2 = 8
+ ELSEIF (IST2.EQ.61) THEN
+ IDX2 = 9
+ ELSEIF (IST2.EQ.62) THEN
+ IDX2 = 10
+ ELSE
+c WRITE(LOUT,*)
+c & ' CHASTA: unknown parton status flag (',
+c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+ ID = IDHKK(JMOHKK(2,IDX))
+ IF (ABS(ID).LE.4) THEN
+ IF (ID.GT.0) THEN
+ ITYP2 = 1
+ ELSE
+ ITYP2 = 2
+ ENDIF
+ ELSEIF (ABS(ID).GE.1000) THEN
+ IF (ID.GT.0) THEN
+ ITYP2 = 3
+ ELSE
+ ITYP2 = 4
+ ENDIF
+ ELSEIF (ID.EQ.21) THEN
+ ITYP2 = 5
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent parton identity (',
+ & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+*
+* fill counter
+ ITYPE = ICHTYP(ITYP1,ITYP2)
+ IF (ITYPE.NE.0) THEN
+ ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
+ NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
+ ICHCFG(IDX1,IDX2,ITYPE,2) =
+ & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
+
+ NCHAIN = NCHAIN+1
+ IF (NCHAIN.GT.MAXCHN) THEN
+ WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
+ & NCHAIN,MAXCHN
+ STOP
+ ENDIF
+ IDXCHN(1,NCHAIN) = IDX
+ IDXCHN(2,NCHAIN) = ITYPE
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent chain at entry ',IDX
+ GOTO 21
+ ENDIF
+ ENDIF
+ 21 CONTINUE
+*
+* write statistics to output unit
+*
+ ELSEIF (MODE.EQ.1) THEN
+ WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
+ DO 31 I=1,10
+ WRITE(LOUT,'(/,2A)')
+ & ' -----------------------------------------',
+ & '------------------------------------'
+ WRITE(LOUT,'(2A)')
+ & ' p\\t 21 22 31 32 41',
+ & ' 42 51 52 61 62'
+ WRITE(LOUT,'(2A)')
+ & ' -----------------------------------------',
+ & '------------------------------------'
+ DO 32 J=1,10
+ ITOT(J) = 0
+ DO 33 K=1,9
+ ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
+ 33 CONTINUE
+ 32 CONTINUE
+ WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
+ DO 34 K=1,9
+ ISUM = 0
+ DO 35 J=1,10
+ ISUM = ISUM+ICHCFG(I,J,K,1)
+ 35 CONTINUE
+ IF (ISUM.GT.0)
+ & WRITE(LOUT,'(1X,A5,2X,10I7)')
+ & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
+ 34 CONTINUE
+C WRITE(LOUT,'(2A)')
+C & ' -----------------------------------------',
+C & '-------------------------------'
+ 31 CONTINUE
+*
+ ELSE
+ WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
+ STOP
+ ENDIF
+
+ RETURN
+ END
+*$ CREATE PHO_PHIST.FOR
+*COPY PHO_PHIST
+*
+*===pohist=============================================================*
+*
+ SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+ ILAB = 0
+ IF (IMODE.EQ.10) THEN
+ IMODE = 1
+ ILAB = 1
+ ENDIF
+ IF (ABS(IMODE).LT.1000) THEN
+* PHOJET-statistics
+C CALL POHISX(IMODE,WEIGHT)
+ IF (IMODE.EQ.-1) THEN
+ MODE = 1
+ XSTOT(1,1,1) = WEIGHT
+ ENDIF
+ IF (IMODE.EQ. 1) MODE = 2
+ IF (IMODE.EQ.-2) MODE = 3
+ IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
+C IF (MODE.EQ.3) WRITE(LOUT,*)
+C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
+ CALL DT_HISTOG(MODE)
+ CALL DT_USRHIS(MODE)
+ ELSE
+* DTUNUC-statistics
+ MODE = IMODE/1000
+C IF (MODE.EQ.3) WRITE(LOUT,*)
+C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
+ CALL DT_HISTOG(MODE)
+ CALL DT_USRHIS(MODE)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_SWPPHO.FOR
+*COPY DT_SWPPHO
+*
+*===swppho=============================================================*
+*
+ SUBROUTINE DT_SWPPHO(ILAB)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+
+ LOGICAL LSTART
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+**PHOJET105a
+C PARAMETER (NMXHEP=2000)
+C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
+C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C COMMON /PLASAV/ PLAB
+**PHOJET110
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+**
+ DATA ICOUNT/0/
+
+ DATA LSTART /.TRUE./
+
+C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
+ IF ((IFRAME.EQ.1).AND.LSTART) THEN
+ UMO = ECM
+ ELA = ZERO
+ PLA = ZERO
+ IDP = IDT_ICIHAD(IFPAP(1))
+ IDT = IDT_ICIHAD(IFPAP(2))
+ VIRT = PVIRT(1)
+ CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
+ PLAB = PLA
+ LSTART = .FALSE.
+ ENDIF
+
+ NHKK = 0
+ ICOUNT = ICOUNT+1
+C NEVHKK = NEVHEP
+ NEVHKK = ICOUNT
+ IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
+ DO 1 I=3,NHEP
+ IF (ISTHEP(I).EQ.1) THEN
+ NHKK = NHKK+1
+ ISTHKK(NHKK) = 1
+ IDHKK(NHKK) = IDHEP(I)
+ JMOHKK(1,NHKK) = 0
+ JMOHKK(2,NHKK) = 0
+ JDAHKK(1,NHKK) = 0
+ JDAHKK(2,NHKK) = 0
+ DO 2 K=1,4
+ PHKK(K,NHKK) = PHEP(K,I)
+ VHKK(K,NHKK) = ZERO
+ WHKK(K,NHKK) = ZERO
+ 2 CONTINUE
+ IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
+ & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
+ & PHKK(3,NHKK),PHKK(4,NHKK),-3)
+ PHKK(5,NHKK) = PHEP(5,I)
+ IDRES(NHKK) = 0
+ IDXRES(NHKK) = 0
+ NOBAM(NHKK) = 0
+ IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
+ IDCH(NHKK) = 0
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_HISTOG.FOR
+*COPY DT_HISTOG
+*
+*===histog=============================================================*
+*
+ SUBROUTINE DT_HISTOG(MODE)
+
+************************************************************************
+* This version dated 25.03.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LFSP,LRNL
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+
+* flags for activated histograms
+ COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+
+ IEVHKK = NEVHKK
+ GOTO (1,2,3) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+ ICEVT = 0
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ ICEVT = ICEVT+1
+
+ DO 20 I=1,NHKK
+ CALL DT_SWPFSP(I,LFSP,LRNL)
+ IF (LFSP) THEN
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
+ ENDIF
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
+ 20 CONTINUE
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
+
+ RETURN
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
+
+ RETURN
+ END
+
+*$ CREATE DT_SWPFSP.FOR
+*COPY DT_SWPFSP
+*
+*===swpfsp=============================================================*
+*
+ SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+ PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
+ & PI =TWOPI/TWO,
+ & BOG =TWOPI/360.0D0)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* INCLUDE '(DIMPAR)'
+* Taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(PAREVT)'
+* Taken from FLUKA
+ PARAMETER ( FRDIFF = 0.2D+00 )
+ PARAMETER ( ETHSEA = 1.0D+00 )
+*
+ LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+ & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
+ & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
+ & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
+ COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
+ & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+ & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+ & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
+ & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
+ & LVP2XX, LV2XNW, LNWV2X, LEVFIN
+
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+
+ LOGICAL LFSP,LRNL
+
+ LFSP = .FALSE.
+ LRNL = .FALSE.
+ ISTRNL = 1000
+ MULDEF = 1
+ IF (LEVPRT) ISTRNL = 1001
+
+ IF (ABS(ISTHKK(IDX)).EQ.1) THEN
+ IST = ISTHKK(IDX)
+ IDPDG = IDHKK(IDX)
+ LFRAG = .FALSE.
+ IF (IDHKK(IDX).LT.80000) THEN
+ IDBJT = IDBAM(IDX)
+ IBARY = IIBAR(IDBJT)
+ ICHAR = IICH(IDBJT)
+ AMASS = AAM(IDBJT)
+ ELSEIF (IDHKK(IDX).EQ.80000) THEN
+ IDBJT = 0
+ IBARY = IDRES(IDX)
+ ICHAR = IDXRES(IDX)
+ AMASS = PHKK(5,IDX)
+ INUT = IBARY-ICHAR
+ IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
+ IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
+ IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
+ IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
+ IF (IDBJT.EQ.0) LFRAG = .TRUE.
+ ELSE
+ GOTO 9999
+ ENDIF
+ PE = PHKK(4,IDX)
+ PX = PHKK(1,IDX)
+ PY = PHKK(2,IDX)
+ PZ = PHKK(3,IDX)
+ PT2 = PX**2+PY**2
+ PT = SQRT(PT2)
+ PTOT = SQRT(PT2+PZ**2)
+ SINTHE = PT/MAX(PTOT,TINY14)
+ COSTHE = PZ/MAX(PTOT,TINY14)
+ IF (COSTHE.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTHE.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTHE)
+ ENDIF
+ EKIN = PE-AMASS
+**sr 15.4.96 new E_t-definition
+ IF (IBARY.GT.0) THEN
+ ET = EKIN*SINTHE
+ ELSEIF (IBARY.LT.0) THEN
+ ET = (EKIN+TWO*AMASS)*SINTHE
+ ELSE
+ ET = PE*SINTHE
+ ENDIF
+**
+ XLAB = PZ/MAX(PPROJ,TINY14)
+C XLAB = PE/MAX(EPROJ,TINY14)
+ BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
+ & *(ONE+AMASS/MAX(PE,TINY14)) ))
+ PPLUS = PE+PZ
+ PMINUS = PE-PZ
+ IF (PMINUS.GT.TINY14) THEN
+ YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
+ ELSE
+ YY = 100.0D0
+ ENDIF
+ IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
+ ETA = -LOG(TAN(THETA/TWO))
+ ELSE
+ ETA = 100.0D0
+ ENDIF
+ IF (IFRAME.EQ.1) THEN
+ CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
+ PPLUS = EECMS+PZCMS
+ PMINUS = EECMS-PZCMS
+ IF ((PPLUS*PMINUS).GT.TINY14) THEN
+ YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
+ ELSE
+ YYCMS = 100.0D0
+ ENDIF
+ PTOTCM = SQRT(PT2+PZCMS**2)
+ COSTH = PZCMS/MAX(PTOTCM,TINY14)
+ IF (COSTH.GT.ONE) THEN
+ THECMS = ZERO
+ ELSEIF (COSTH.LT.-ONE) THEN
+ THECMS = TWOPI/2.0D0
+ ELSE
+ THECMS = ACOS(COSTH)
+ ENDIF
+ IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
+ ETACMS = -LOG(TAN(THECMS/TWO))
+ ELSE
+ ETACMS = 100.0D0
+ ENDIF
+ XF = PZCMS/MAX(PPCM,TINY14)
+ THECMS = THECMS/BOG
+ ELSE
+ PZCMS = PZ
+ EECMS = PE
+ YYCMS = YY
+ ETACMS = ETA
+ XF = XLAB
+ THECMS = THETA/BOG
+ ENDIF
+ THETA = THETA/BOG
+
+* set flag for "grey/black"
+ LGREY = .FALSE.
+ LBLACK = .FALSE.
+ EK = EKIN
+ IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
+ IF (MULDEF.EQ.1) THEN
+* EMU01-Def.
+ IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
+ & (EK.LE.375.0D-3) ).OR.
+ & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
+ & (EK.LE. 56.0D-3) ).OR.
+ & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
+ & (EK.LE. 56.0D-3) ).OR.
+ & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
+ & (EK.LE.198.0D-3) ).OR.
+ & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
+ & (EK.LE.198.0D-3) ).OR.
+ & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
+ & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
+ & (IDBJT.NE.16).AND.
+ & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
+ & LGREY = .TRUE.
+ IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
+ & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
+ & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
+ & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
+ & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
+ & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
+ & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
+ & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
+ & LBLACK = .TRUE.
+ ELSE
+* common Def.
+ IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
+ IF (BETA.LE.0.23D0) LBLACK=.TRUE.
+ ENDIF
+ LFSP = .TRUE.
+ ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
+ IST = ISTHKK(IDX)
+ IDPDG = IDHKK(IDX)
+ LFRAG = .TRUE.
+ IDBJT = 0
+ IBARY = IDRES(IDX)
+ ICHAR = IDXRES(IDX)
+ AMASS = PHKK(5,IDX)
+ PE = PHKK(4,IDX)
+ PX = PHKK(1,IDX)
+ PY = PHKK(2,IDX)
+ PZ = PHKK(3,IDX)
+ PT2 = PX**2+PY**2
+ PT = SQRT(PT2)
+ PTOT = SQRT(PT2+PZ**2)
+ SINTHE = PT/MAX(PTOT,TINY14)
+ COSTHE = PZ/MAX(PTOT,TINY14)
+ IF (COSTHE.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTHE.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTHE)
+ ENDIF
+ EKIN = PE-AMASS
+**sr 15.4.96 new E_t-definition
+C ET = PE*SINTHE
+ ET = EKIN*SINTHE
+**
+ IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
+ ETA = -LOG(TAN(THETA/TWO))
+ ELSE
+ ETA = 100.0D0
+ ENDIF
+ THETA = THETA/BOG
+ LRNL = .TRUE.
+ ENDIF
+
+ 9999 CONTINUE
+ RETURN
+ END
+
+*$ CREATE DT_HIMULT.FOR
+*COPY DT_HIMULT
+*
+*===himult=============================================================*
+*
+ SUBROUTINE DT_HIMULT(MODE)
+
+************************************************************************
+* Tables of average energies/multiplicities. *
+* This version dated 30.08.2000 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+
+ PARAMETER (SWMEXP=1.7D0)
+
+ CHARACTER*8 ANAMEH(4)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+ PARAMETER (NOPART=210)
+ DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
+ & AVPT(4,NOPART),IAVPT(4,NOPART)
+ DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
+
+ GOTO (1,2,3) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+ DO 10 I=1,NOPART
+ DO 11 J=1,4
+ AVMULT(J,I) = ZERO
+ AVE(J,I) = ZERO
+ AVSWM(J,I) = ZERO
+ AVPT(J,I) = ZERO
+ IAVPT(J,I) = 0
+ 11 CONTINUE
+ 10 CONTINUE
+
+ RETURN
+
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ IF (PE.LT.0.0D0) THEN
+ WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
+ RETURN
+ ENDIF
+ IF (.NOT.LFRAG) THEN
+ IVEL = 2
+ IF (LGREY) IVEL = 3
+ IF (LBLACK) IVEL = 4
+ AVE(1,IDBJT) = AVE(1,IDBJT) +PE
+ AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
+ AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
+ AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
+ IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
+ IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
+ AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
+ AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
+ AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
+ AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
+ IF (IDBJT.LT.116) THEN
+* total energy, multiplicity
+ AVE(1,30) = AVE(1,30) +PE
+ AVE(IVEL,30) = AVE(IVEL,30)+PE
+ AVPT(1,30) = AVPT(1,30) +PT
+ AVPT(IVEL,30) = AVPT(IVEL,30)+PT
+ IAVPT(1,30) = IAVPT(1,30) +1
+ IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
+ AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
+ AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
+ AVMULT(1,30) = AVMULT(1,30) +ONE
+ AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
+* charged energy, multiplicity
+ IF (ICHAR.LT.0) THEN
+ AVE(1,26) = AVE(1,26) +PE
+ AVE(IVEL,26) = AVE(IVEL,26)+PE
+ AVPT(1,26) = AVPT(1,26) +PT
+ AVPT(IVEL,26) = AVPT(IVEL,26)+PT
+ IAVPT(1,26) = IAVPT(1,26) +1
+ IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
+ AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
+ AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
+ AVMULT(1,26) = AVMULT(1,26) +ONE
+ AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
+ ENDIF
+ IF (ICHAR.NE.0) THEN
+ AVE(1,27) = AVE(1,27) +PE
+ AVE(IVEL,27) = AVE(IVEL,27)+PE
+ AVPT(1,27) = AVPT(1,27) +PT
+ AVPT(IVEL,27) = AVPT(IVEL,27)+PT
+ IAVPT(1,27) = IAVPT(1,27) +1
+ IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
+ AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
+ AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
+ AVMULT(1,27) = AVMULT(1,27) +ONE
+ AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+ WRITE(LOUT,3000)
+ 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
+ & 29X,'---------------------',/)
+ IF (MULDEF.EQ.1) THEN
+ WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
+ ELSE
+ BETGRE = 0.7D0
+ BETBLC = 0.23D0
+ WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
+ 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
+ & ,F4.2,' black: beta < ',F4.2,/)
+ ENDIF
+ WRITE(LOUT,3003) SWMEXP
+ 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
+ & 13X,'| total fast',
+C & ' grey black K f(',F3.1,')',/,1X,
+ & ' grey black <pt> f(',F3.1,')',/,1X,
+ & '------------+--------------',
+ & '-------------------------------------------------')
+ DO 30 I=1,NOPART
+ DO 31 J=1,4
+ AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
+ AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
+ AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
+ AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
+ 31 CONTINUE
+ IF (I.LE.115) THEN
+ WRITE(LOUT,3004) ANAME(I),I,
+ & AVMULT(1,I),AVMULT(2,I),
+ & AVMULT(3,I),AVMULT(4,I),
+C & AVE(1,I),AVSWM(1,I)
+ & AVPT(1,I),AVSWM(1,I)
+ ELSEIF (I.LE.119) THEN
+ WRITE(LOUT,3004) ANAMEH(I-115),I,
+ & AVMULT(1,I),AVMULT(2,I),
+ & AVMULT(3,I),AVMULT(4,I),
+C & AVE(1,I),AVSWM(1,I)
+ & AVPT(1,I),AVSWM(1,I)
+ ENDIF
+ 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
+ 30 CONTINUE
+**temporary
+C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
+C & AVMULT(3,27)+AVMULT(4,27)
+**
+
+ RETURN
+ END
+
+*$ CREATE DT_HISTAT.FOR
+*COPY DT_HISTAT
+*
+*===histat=============================================================*
+*
+ SUBROUTINE DT_HISTAT(IDX,MODE)
+
+************************************************************************
+* This version dated 26.02.96 is written by S. Roesler *
+* *
+* Last change 27.12.2006 by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+ PARAMETER (NDIM=199)
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: cross sections
+ COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+ & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+ & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+ & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+ & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+ & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+ & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+ & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+ & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+ & BSLOPE,NEBINI,NQBINI
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+* INCLUDE '(DIMPAR)'
+* Taken from FLUKA
+ PARAMETER ( MXXRGN =20000 )
+ PARAMETER ( MXXMDF = 710 )
+ PARAMETER ( MXXMDE = 702 )
+ PARAMETER ( MFSTCK =40000 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXPSCS =30000 )
+ PARAMETER ( MXGLWN = 300 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 260 )
+ PARAMETER ( MXSEAX = 20 )
+ PARAMETER ( MXHTNC = MXSEAX + 1 )
+ PARAMETER ( ICOMAX = 2400 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+ PARAMETER ( NQSTIS = 46 )
+ PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+ PARAMETER ( MKBMX1 = 11 )
+ PARAMETER ( MKBMX2 = 11 )
+ PARAMETER ( MXIRRD = 2500 )
+ PARAMETER ( MXTRDC = 1500 )
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBLNMX = 40000000 )
+
+* INCLUDE '(PAREVT)'
+* Taken from FLUKA
+ PARAMETER ( FRDIFF = 0.2D+00 )
+ PARAMETER ( ETHSEA = 1.0D+00 )
+*
+ LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+ & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
+ & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
+ & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
+ COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
+ & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+ & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+ & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
+ & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
+ & LVP2XX, LV2XNW, LNWV2X, LEVFIN
+
+* INCLUDE '(FRBKCM)'
+* Taken from FLUKA
+* Maximum number of fragments to be emitted:
+ PARAMETER ( MXFFBK = 6 )
+ PARAMETER ( MXZFBK = 10 )
+ PARAMETER ( MXNFBK = 12 )
+ PARAMETER ( MXAFBK = 16 )
+ PARAMETER ( MXASST = 25 )
+ PARAMETER ( NXAFBK = MXAFBK + 1 )
+ PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
+ PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
+ PARAMETER ( MXPSST = 700 )
+* Maximum number of pre-computed break-up combinations
+ PARAMETER ( MXPPFB = 42500 )
+* Maximum number of break-up combinations, including special
+* run-time ones:
+ PARAMETER ( MXPSFB = 43000 )
+* Base for J multiplicity encoding:
+ PARAMETER ( IBFRBK = 73 )
+* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
+* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
+* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
+* --> Ibfrbk^(Jpwfbx+1) < 2100000000
+ PARAMETER ( JPWFBX = 4 )
+ LOGICAL LFRMBK, LNCMSS
+ COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
+ & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
+ & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
+ & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
+ & IFRBKN (MXPSST), IFRBKZ (MXPSST),
+ & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
+ & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
+ & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
+ & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
+ & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
+
+* INCLUDE '(EVAFLG)'
+* Taken from FLUKA
+ LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
+ & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
+ & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
+ & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
+ COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
+ & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
+ & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
+ & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
+ & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
+ & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
+ & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
+ & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
+
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+
+* statistics: double-Pomeron exchange
+ COMMON /DTFLG2/ INTFLG,IPOPO
+
+ DIMENSION EMUSAM(NCOMPX)
+
+ CHARACTER*13 CMSG(3)
+ DATA CMSG /'not requested','not requested','not requested'/
+
+ GOTO (1,2,3,4,5) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ DO 10 I=1,NCOMPX
+ EMUSAM(I) = ZERO
+ 10 CONTINUE
+ ENDIF
+* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
+ NINCGE = 0
+ DO 11 I=1,2
+ EXCDPM(I) = ZERO
+ EXCDPM(I+2) = ZERO
+ EXCEVA(I) = ZERO
+ NINCWO(I) = 0
+ NINCEV(I) = 0
+ NRESTO(I) = 0
+ NRESPR(I) = 0
+ NRESNU(I) = 0
+ NRESBA(I) = 0
+ NRESPB(I) = 0
+ NRESCH(I) = 0
+ NRESEV(I) = 0
+ NRESEV(I+2) = 0
+ NEVAGA(I) = 0
+ NEVAHT(I) = 0
+ NEVAFI(1,I) = 0
+ NEVAFI(2,I) = 0
+ DO 12 J=1,6
+ IF (J.LE.2) NINCHR(I,J) = 0
+ IF (J.LE.3) NINCCO(I,J) = 0
+ IF (J.LE.4) NINCST(I,J) = 0
+ NEVA(I,J) = 0
+ 12 CONTINUE
+ DO 13 J=1,210
+ NEVAHY(1,I,J) = 0
+ NEVAHY(2,I,J) = 0
+ 13 CONTINUE
+ 11 CONTINUE
+ MAXGEN = 0
+**dble Po statistics.
+ KPOPO = 0
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ IF (IST.EQ.-1) THEN
+ IF (.NOT.LFRAG) THEN
+ IF (IDPDG.EQ.2212) THEN
+ NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
+ ELSEIF (IDPDG.EQ.2112) THEN
+ NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
+ ELSEIF (IDPDG.EQ.22) THEN
+ NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
+ ELSEIF (IDPDG.EQ.80000) THEN
+ IF (IDBJT.EQ.116) THEN
+ NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
+ ELSEIF (IDBJT.EQ.117) THEN
+ NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
+ ELSEIF (IDBJT.EQ.118) THEN
+ NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
+ ELSEIF (IDBJT.EQ.119) THEN
+ NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
+ ENDIF
+ ENDIF
+ ELSE
+* heavy fragments (here: fission products only)
+ NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
+ NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
+ NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
+ ENDIF
+ ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
+ IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
+ ENDIF
+
+ RETURN
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+
+**dble Po statistics.
+C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
+C & '# evts. / # dble-Po. evts / s_in / s_popo :',
+C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
+
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ WRITE(LOUT,3000)
+ 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
+ & 22X,'----------------------------',/,/,19X,
+ & 'mass charge fraction',/,39X,
+ & 'input treated',/)
+ DO 30 I=1,NCOMPO
+ WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
+ & EMUSAM(I)/DBLE(ICEVT)
+ 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
+ 30 CONTINUE
+ ENDIF
+
+* i.n.c. statistics: output
+ WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
+ 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
+ & 22X,'---------------------------------',/,/,1X,
+ & 'no. of events for normalization: (accepted final events,',
+ & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
+ & /,1X,'no. of rejected events due to intranuclear',
+ & ' cascade',15X,I6,/)
+ ICEV = MAX(ICEVT,1)
+ ICEV1 = ICEV
+ IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
+ WRITE(LOUT,3002)
+ & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
+ & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
+ & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
+ & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
+ 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
+ & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
+ & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
+ & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
+ & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
+ & /,1X,'maximum no. of generations treated (maximum allowed:'
+ & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
+ & ' interactions in proj./ target (mean per evt1)',
+ & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
+ & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
+ & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
+ & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
+ WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
+ & IREXCI(1)+IREXCI(2)+IREXCI(3)
+ 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
+ & 'evaporation',/,22X,'-----------------------------',
+ & '------------',/,/,1X,'no. of events for normal.: ',
+ & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
+ & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
+ & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
+
+ WRITE(LOUT,3004)
+ 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
+ ICEV = MAX(NRESEV(2),1)
+ WRITE(LOUT,3005)
+ & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
+ & (EXCDPM(I)/DBLE(ICEV),I=1,2),
+ & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
+ 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
+ & 'proj. / target',/,/,8X,'total number of particles',15X,
+ & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
+ & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
+ & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
+ & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
+ & 8X,'excitation energy per nucleon ',2E11.3,/,/)
+
+* evaporation / fission / fragmentation statistics: output
+ ICEV = MAX(NRESEV(2),1)
+ ICEV1 = MAX(NRESEV(4),1)
+ NTEVA1 =
+ & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
+ NTEVA2 =
+ & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
+ IF (LEVPRT) THEN
+
+ IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
+
+ IF (LFRMBK) CMSG(2) = 'requested '
+ IF (LDEEXG) CMSG(3) = 'requested '
+ WRITE(LOUT,3006)
+ & CMSG,
+ & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
+ & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
+ 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
+ & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
+ & 'deexcitation:',2X,A13,/,/,
+ & 1X,'evaporation/deexcitation: (mean values per evt1) ',
+ & 'proj. / target',/,/,8X,'total number of evap. particles',
+ & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
+ & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
+ & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
+ & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
+ & 'heavy fragments',25X,2F9.3,/)
+
+ IF (IEVFSS.EQ.1) THEN
+
+ WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
+ & NEVAFI(2,1),NEVAFI(2,2),
+ & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
+ & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
+ 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
+ & 12X,'out of which fission occured',8X,2I9,/,
+ & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
+ ENDIF
+
+C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
+
+C WRITE(LOUT,3008)
+C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
+C & ' proj. / target',/)
+C DO 31 I=1,210
+C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
+C WRITE(LOUT,3009) I,
+C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
+C3009 FORMAT(38X,I3,3X,2E12.3)
+C ENDIF
+C 31 CONTINUE
+C WRITE(LOUT,3010)
+C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
+C & ' proj. / target',/)
+C DO 32 I=1,210
+C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
+C WRITE(LOUT,3011) I,
+C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
+C3011 FORMAT(38X,I3,3X,2E12.3)
+C ENDIF
+C 32 CONTINUE
+C WRITE(LOUT,*)
+C ENDIF
+ ELSE
+ WRITE(LOUT,3012)
+ 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
+ & 'Evaporation: not requested',/)
+ ENDIF
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 4 CONTINUE
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ DO 40 I=1,NCOMPO
+ IF (IT.EQ.IEMUMA(I)) THEN
+ EMUSAM(I) = EMUSAM(I)+ONE
+ ENDIF
+ 40 CONTINUE
+ ENDIF
+ NINCGE = NINCGE+MAXGEN
+ MAXGEN = 0
+**dble Po statistics.
+ IF (IPOPO.EQ.1) KPOPO = KPOPO+1
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 5 CONTINUE
+ IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
+ IB = IIBAR(IDBAM(IDX))
+ IC = IICH(IDBAM(IDX))
+ J = ISTHKK(IDX)-14
+ IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
+ NINCST(J,1) = NINCST(J,1)+1
+ ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
+ NINCST(J,2) = NINCST(J,2)+1
+ ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
+ NINCST(J,3) = NINCST(J,3)+1
+ ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
+ NINCST(J,4) = NINCST(J,4)+1
+ ENDIF
+ ELSEIF (ISTHKK(IDX).EQ.17) THEN
+ NINCWO(1) = NINCWO(1)+1
+ ELSEIF (ISTHKK(IDX).EQ.18) THEN
+ NINCWO(2) = NINCWO(2)+1
+ ELSEIF (ISTHKK(IDX).EQ.1001) THEN
+ IB = IDRES(IDX)
+ IC = IDXRES(IDX)
+ IF (IC.GT.0) THEN
+ NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
+ NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
+ ENDIF
+ NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
+ ENDIF
+
+ RETURN
+ END
+*$ CREATE DT_NEWHGR.FOR
+*COPY DT_NEWHGR
+*
+*===newhgr=============================================================*
+*
+ SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
+
+************************************************************************
+* *
+* Histogram initialization. *
+* *
+* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
+* XLIM3 bin size *
+* IBIN > 0 number of bins in equidistant lin. binning *
+* = -1 reset histograms *
+* < -1 |IBIN| number of bins in equidistant log. *
+* binning or log. binning in user def. struc. *
+* XLIMB(*) user defined bin structure *
+* *
+* The bin structure is sensitive to *
+* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
+* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
+* XLIMB, IBIN if XLIM3 < 0 *
+* *
+* *
+* output: IREFN histogram index *
+* (= -1 for inconsistent histogr. request) *
+* *
+* This subroutine is based on a original version by R. Engel. *
+* This version dated 22.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LSTART
+
+ PARAMETER (ZERO = 0.0D0,
+ & TINY = 1.0D-10)
+
+ DIMENSION XLIMB(*)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA LSTART /.TRUE./
+
+* reset histogram counter
+ IF (LSTART.OR.(IBIN.EQ.-1)) THEN
+ IHISL = 0
+ IF (IBIN.EQ.-1) RETURN
+ LSTART = .FALSE.
+ ENDIF
+
+ IHIS = IHISL+1
+* check for maximum number of allowed histograms
+ IF (IHIS.GT.NHIS) THEN
+ WRITE(LOUT,1003) IHIS,NHIS,IHIS
+ 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
+ & I4,') exceeds array size (',I4,')',/,21X,
+ & 'histogram',I3,' skipped!')
+ GOTO 9999
+ ENDIF
+
+ IREFN = IHIS
+ IBINS(IHIS) = ABS(IBIN)
+* check requested number of bins
+ IF (IBINS(IHIS).GE.NDIM) THEN
+ WRITE(LOUT,1000) IBIN,NDIM,NDIM
+ 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
+ & I3,') exceeds array size (',I3,')',/,21X,
+ & 'and will be reset to ',I3)
+ IBINS(IHIS) = NDIM
+ ENDIF
+ IF (IBINS(IHIS).EQ.0) THEN
+ WRITE(LOUT,1001) IBIN,IHIS
+ 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
+ & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
+ GOTO 9999
+ ENDIF
+
+* initialize arrays
+ DO 1 I=1,NDIM
+ DO 2 K=1,3
+ HIST(K,IHIS,I) = ZERO
+ HIST(K+3,IHIS,I) = ZERO
+ TMPHIS(K,IHIS,I) = ZERO
+ 2 CONTINUE
+ HIST(7,IHIS,I) = ZERO
+ 1 CONTINUE
+ DENTRY(1,IHIS)= ZERO
+ DENTRY(2,IHIS)= ZERO
+ OVERF(IHIS) = ZERO
+ UNDERF(IHIS) = ZERO
+ TMPUFL(IHIS) = ZERO
+ TMPOFL(IHIS) = ZERO
+
+* bin str. sensitive to lower edge, bin size, and numb. of bins
+ IF (XLIM3.GT.ZERO) THEN
+ DO 3 K=1,IBINS(IHIS)+1
+ HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
+ 3 CONTINUE
+ ISWI(IHIS) = 1
+* bin str. sensitive to lower/upper edge and numb. of bins
+ ELSEIF (XLIM3.EQ.ZERO) THEN
+* linear binning
+ IF (IBIN.GT.0) THEN
+ XLOW = XLIM1
+ XHI = XLIM2
+ IF (XLIM2.LE.XLIM1) THEN
+ WRITE(LOUT,1002) XLIM1,XLIM2
+ 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
+ & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ ISWI(IHIS) = 1
+ ELSEIF (IBIN.LT.-1) THEN
+* logarithmic binning
+ IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
+ WRITE(LOUT,1004) XLIM1,XLIM2
+ 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
+ & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ IF (XLIM2.LE.XLIM1) THEN
+ WRITE(LOUT,1005) XLIM1,XLIM2
+ 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
+ & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ XLOW = LOG10(XLIM1)
+ XHI = LOG10(XLIM2)
+ ISWI(IHIS) = 3
+ ENDIF
+ DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
+ DO 4 K=1,IBINS(IHIS)+1
+ HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
+ 4 CONTINUE
+ ELSE
+* user defined bin structure
+ DO 5 K=1,IBINS(IHIS)+1
+ IF (IBIN.GT.0) THEN
+ HIST(1,IHIS,K) = XLIMB(K)
+ ISWI(IHIS) = 2
+ ELSEIF (IBIN.LT.-1) THEN
+ HIST(1,IHIS,K) = LOG10(XLIMB(K))
+ ISWI(IHIS) = 4
+ ENDIF
+ 5 CONTINUE
+ ENDIF
+
+* histogram accepted
+ IHISL = IHIS
+
+ RETURN
+
+ 9999 CONTINUE
+ IREFN = -1
+ RETURN
+ END
+
+*$ CREATE DT_FILHGR.FOR
+*COPY DT_FILHGR
+*
+*===filhgr=============================================================*
+*
+ SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
+
+************************************************************************
+* *
+* Scoring for histogram IHIS. *
+* *
+* This subroutine is based on a original version by R. Engel. *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & TINY = 1.0D-10)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA NCEVT /1/
+
+ X = XI
+ Y = YI
+
+* dump content of temorary arrays into histograms
+ IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
+ CALL DT_EVTHIS(IDUM)
+ NCEVT = NEVT
+ ENDIF
+
+* check histogram index
+ IF (IHIS.EQ.-1) RETURN
+ IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
+C WRITE(LOUT,1000) IHIS,IHISL
+ 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
+ & ' out of range (1..',I3,')')
+ RETURN
+ ENDIF
+
+ IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
+* bin structure not explicitly given
+ IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
+ DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
+ IF (X.LT.HIST(1,IHIS,1)) THEN
+ I1 = 0
+ ELSE
+ I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
+ ENDIF
+
+ ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
+* user defined bin structure
+ IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
+ IF (X.LT.HIST(1,IHIS,1)) THEN
+ I1 = 0
+ ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
+ I1 = IBINS(IHIS)+1
+ ELSE
+* binary sort algorithm
+ KMIN = 0
+ KMAX = IBINS(IHIS)+1
+ 1 CONTINUE
+ IF ((KMAX-KMIN).EQ.1) GOTO 2
+ KK = (KMAX+KMIN)/2
+ IF (X.LE.HIST(1,IHIS,KK)) THEN
+ KMAX=KK
+ ELSE
+ KMIN=KK
+ ENDIF
+ GOTO 1
+ 2 CONTINUE
+ I1 = KMIN
+ ENDIF
+
+ ELSE
+ WRITE(LOUT,1001)
+ 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
+ RETURN
+ ENDIF
+
+* scoring
+ IF (I1.LE.0) THEN
+ TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
+ ELSEIF (I1.LE.IBINS(IHIS)) THEN
+ TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
+ IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
+ TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
+ ELSE
+ TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
+ ENDIF
+ TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
+ ELSE
+ TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_EVTHIS.FOR
+*COPY DT_EVTHIS
+*
+*===evthis=============================================================*
+*
+ SUBROUTINE DT_EVTHIS(NEVT)
+
+************************************************************************
+* Dump content of temorary histograms into /DTHIS1/. This subroutine *
+* is called after each event and for the last event before any call *
+* to OUTHGR. *
+* NEVT number of events dumped, this is only needed to *
+* get the normalization after the last event *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LNOETY
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & TINY = 1.0D-10)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA NCEVT /0/
+
+ NCEVT = NCEVT+1
+ NEVT = NCEVT
+
+ DO 1 I=1,IHISL
+ LNOETY = .TRUE.
+ DO 2 J=1,IBINS(I)
+ IF (TMPHIS(1,I,J).GT.ZERO) THEN
+ LNOETY = .FALSE.
+ HIST(2,I,J) = HIST(2,I,J)+ONE
+ HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
+ DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
+ AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
+ HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
+ HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
+ HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
+ HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
+ TMPHIS(1,I,J) = ZERO
+ TMPHIS(2,I,J) = ZERO
+ TMPHIS(3,I,J) = ZERO
+ ENDIF
+ 2 CONTINUE
+ IF (LNOETY) THEN
+ IF (TMPUFL(I).GT.ZERO) THEN
+ UNDERF(I) = UNDERF(I)+ONE
+ TMPUFL(I) = ZERO
+ ELSEIF (TMPOFL(I).GT.ZERO) THEN
+ OVERF(I) = OVERF(I)+ONE
+ TMPOFL(I) = ZERO
+ ENDIF
+ ELSE
+ DENTRY(1,I) = DENTRY(1,I)+ONE
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_OUTHGR.FOR
+*COPY DT_OUTHGR
+*
+*===outhgr=============================================================*
+*
+ SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
+ & ILOGY,INORM,NMODE)
+
+************************************************************************
+* *
+* Plot histogram(s) to standard output unit *
+* *
+* I1..6 indices of histograms to be plotted *
+* CHEAD,IHEAD header string,integer *
+* NEVTS number of events *
+* FAC scaling factor *
+* ILOGY = 1 logarithmic y-axis *
+* INORM normalization *
+* = 0 no further normalization (FAC is obsolete) *
+* = 1 per event and bin width *
+* = 2 per entry and bin width *
+* = 3 per bin entry *
+* = 4 per event and "bin width" x1^2...x2^2 *
+* = 5 per event and "log. bin width" ln x1..ln x2 *
+* = 6 per event *
+* MODE = 0 no output but normalization applied *
+* = 1 all valid histograms separately (small frame) *
+* all valid histograms separately (small frame) *
+* = -1 and tables as histograms *
+* = 2 all valid histograms (one plot, wide frame) *
+* all valid histograms (one plot, wide frame) *
+* = -2 and tables as histograms *
+* *
+* *
+* Note: All histograms to be plotted with one call to this *
+* subroutine and |MODE|=2 must have the same bin structure! *
+* There is no test included ensuring this fact. *
+* *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*72 CHEAD
+
+ PARAMETER (ZERO = 0.0D0,
+ & IZERO = 0,
+ & ONE = 1.0D0,
+ & TWO = 2.0D0,
+ & OHALF = 0.5D0,
+ & EPS = 1.0D-5,
+ & TINY = 1.0D-8,
+ & SMALL = -1.0D8,
+ & RLARGE = 1.0D8 )
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ PARAMETER (NDIM2 = 2*NDIM)
+ DIMENSION XX(NDIM2),YY(NDIM2)
+
+ PARAMETER (NHISTO = 6)
+ DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
+ & IDX(NHISTO)
+
+ CHARACTER*43 CNORM(0:8)
+ DATA CNORM /'no further normalization ',
+ & 'per event and bin width ',
+ & 'per entry1 and bin width ',
+ & 'per bin entry ',
+ & 'per event and "bin width" x1^2...x2^2 ',
+ & 'per event and "log. bin width" ln x1..ln x2',
+ & 'per event ',
+ & 'per bin entry1 ',
+ & 'per entry2 and bin width '/
+
+ IDX1(1) = I1
+ IDX1(2) = I2
+ IDX1(3) = I3
+ IDX1(4) = I4
+ IDX1(5) = I5
+ IDX1(6) = I6
+
+ MODE = NMODE
+
+* initialization if "wide frame" is requested
+ IF (ABS(MODE).EQ.2) THEN
+ DO 1 I=1,NHISTO
+ DO 2 J=1,NDIM
+ XX1(J,I) = ZERO
+ YY1(J,I) = ZERO
+ 2 CONTINUE
+ 1 CONTINUE
+ ENDIF
+
+* plot header
+ WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
+
+* check histogram indices
+ NHI = 0
+ DO 3 I=1,NHISTO
+ IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
+ IF (ISWI(IDX1(I)).NE.0) THEN
+ IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
+ WRITE(LOUT,1000)
+ & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
+ 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
+ & ' histogram ',I3,/,21X,'underflows:',F10.0,
+ & ' overflows: ',F10.0)
+ ELSE
+ NHI = NHI+1
+ IDX(NHI) = IDX1(I)
+ ENDIF
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+ IF (NHI.EQ.0) THEN
+ WRITE(LOUT,1001)
+ 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
+ RETURN
+ ENDIF
+
+* check normalization request
+ IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
+ & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
+ & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
+ & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
+ WRITE(LOUT,1002) NEVTS,INORM,FAC
+ 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
+ & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
+ & 'FAC = ',E11.4)
+ RETURN
+ ENDIF
+
+ WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
+
+* apply normalization
+ DO 4 N=1,NHI
+
+ I = IDX(N)
+
+ IF (ISWI(I).EQ.1) THEN
+ WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
+ 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
+ & ' to',2X,E10.4,',',2X,I3,' bins')
+ ELSEIF (ISWI(I).EQ.2) THEN
+ WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
+ WRITE(LOUT,1007)
+ 1007 FORMAT(1X,'user defined bin structure')
+ ELSEIF (ISWI(I).EQ.3) THEN
+ WRITE(LOUT,1004)
+ & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
+ 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
+ & ' to',2X,E10.4,',',2X,I3,' bins')
+ ELSEIF (ISWI(I).EQ.4) THEN
+ WRITE(LOUT,1004)
+ & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
+ WRITE(LOUT,1007)
+ ELSE
+ WRITE(LOUT,1008) ISWI(I)
+ 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
+ ENDIF
+ WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
+ 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
+ & ' overfl.:',F8.0)
+ WRITE(LOUT,1009) CNORM(INORM)
+ 1009 FORMAT(1X,'normalization: ',A,/)
+
+ DO 5 K=1,IBINS(I)
+ CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
+ YMEAN = FAC*YMEAN
+ YERR = FAC*YERR
+ WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
+ WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
+ 1006 FORMAT(1X,5E11.3)
+* small frame
+ II = 2*K
+ XX(II-1) = HIST(1,I,K)
+ XX(II) = HIST(1,I,K+1)
+ YY(II-1) = YMEAN
+ YY(II) = YMEAN
+* wide frame
+ XX1(K,N) = XMEAN
+ IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
+ & XX1(K,N) = LOG10(XMEAN)
+ YY1(K,N) = YMEAN
+ 5 CONTINUE
+
+* plot small frame
+ IF (ABS(MODE).EQ.1) THEN
+ IBIN2 = 2*IBINS(I)
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ IF(ILOGY.EQ.1) THEN
+ CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
+ ELSE
+ CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
+ ENDIF
+ ENDIF
+
+ 4 CONTINUE
+
+* plot wide frame
+ IF (ABS(MODE).EQ.2) THEN
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ NSIZE = NDIM*NHISTO
+ DXLOW = HIST(1,IDX(1),1)
+ DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
+ YLOW = RLARGE
+ YHI = SMALL
+ DO 6 I=1,NHISTO
+ DO 7 J=1,NDIM
+ IF (YY1(J,I).LT.YLOW) THEN
+ IF (ILOGY.EQ.1) THEN
+ IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
+ ELSE
+ YLOW = YY1(J,I)
+ ENDIF
+ ENDIF
+ IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
+ 7 CONTINUE
+ 6 CONTINUE
+ DY = (YHI-YLOW)/DBLE(NDIM)
+ IF (DY.LE.ZERO) THEN
+ WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
+ & 'OUTHGR: warning! zero bin width for histograms ',
+ & IDX,': ',YLOW,YHI
+ RETURN
+ ENDIF
+ IF (ILOGY.EQ.1) THEN
+ YLOW = LOG10(YLOW)
+ DY = (LOG10(YHI)-YLOW)/100.0D0
+ DO 8 I=1,NHISTO
+ DO 9 J=1,NDIM
+ IF (YY1(J,I).LE.ZERO) THEN
+ YY1(J,I) = YLOW
+ ELSE
+ YY1(J,I) = LOG10(YY1(J,I))
+ ENDIF
+ 9 CONTINUE
+ 8 CONTINUE
+ ENDIF
+ CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE DT_GETBIN.FOR
+*COPY DT_GETBIN
+*
+*===getbin=============================================================*
+*
+ SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
+ & XMEAN,YMEAN,YERR)
+
+************************************************************************
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & TINY35 = 1.0D-35)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ XLOW = HIST(1,IHIS,IBIN)
+ XHI = HIST(1,IHIS,IBIN+1)
+ IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
+ XLOW = 10**XLOW
+ XHI = 10**XHI
+ ENDIF
+ IF (NORM.EQ.2) THEN
+ DX = XHI-XLOW
+ NEVT = INT(DENTRY(1,IHIS))
+ ELSEIF (NORM.EQ.3) THEN
+ DX = ONE
+ NEVT = INT(HIST(2,IHIS,IBIN))
+ ELSEIF (NORM.EQ.4) THEN
+ DX = XHI**2-XLOW**2
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.5) THEN
+ DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.6) THEN
+ DX = ONE
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.7) THEN
+ DX = ONE
+ NEVT = INT(HIST(7,IHIS,IBIN))
+ ELSEIF (NORM.EQ.8) THEN
+ DX = XHI-XLOW
+ NEVT = INT(DENTRY(2,IHIS))
+ ELSE
+ DX = ABS(XHI-XLOW)
+ NEVT = KEVT
+ ENDIF
+ IF (ABS(DX).LT.TINY35) DX = ONE
+ NEVT = MAX(NEVT,1)
+ YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
+ YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
+ YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
+ YSUM = HIST(5,IHIS,IBIN)
+ IF (ABS(YSUM).LT.TINY35) YSUM = ONE
+C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
+ XMEAN = HIST(3,IHIS,IBIN)/YSUM
+ IF (XMEAN.EQ.ZERO) XMEAN = XLOW
+
+ RETURN
+ END
+
+*$ CREATE DT_JOIHIS.FOR
+*COPY DT_JOIHIS
+*
+*===joihis=============================================================*
+*
+ SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
+
+************************************************************************
+* *
+* Operation on histograms. *
+* *
+* input: IH1,IH2 histogram indices to be joined *
+* COPER character defining the requested operation, *
+* i.e. '+', '-', '*', '/' *
+* FAC1,FAC2 factors for joining, i.e. *
+* FAC1*histo1 COPER FAC2*histo2 *
+* *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER COPER*1
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & OHALF = 0.5D0,
+ & TINY8 = 1.0D-8,
+ & SMALL = -1.0D8,
+ & RLARGE = 1.0D8 )
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ PARAMETER (NDIM2 = 2*NDIM)
+ DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
+
+ CHARACTER*43 CNORM(0:6)
+ DATA CNORM /'no further normalization ',
+ & 'per event and bin width ',
+ & 'per entry and bin width ',
+ & 'per bin entry ',
+ & 'per event and "bin width" x1^2...x2^2 ',
+ & 'per event and "log. bin width" ln x1..ln x2',
+ & 'per event '/
+
+* check histogram indices
+ IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
+ & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
+ WRITE(LOUT,1000) IH1,IH2,IHISL
+ 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
+ & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
+ GOTO 9999
+ ENDIF
+
+* check bin structure of histograms to be joined
+ IF (IBINS(IH1).NE.IBINS(IH2)) THEN
+ WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
+ 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
+ & ' and ',I3,' failed',/,21X,
+ & 'due to different numbers of bins (',I3,',',I3,')')
+ GOTO 9999
+ ENDIF
+ DO 1 K=1,IBINS(IH1)+1
+ IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
+ WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
+ 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
+ & ' and ',I3,' failed at bin edge ',I3,/,21X,
+ & 'X1,X2 = ',2E11.4)
+ GOTO 9999
+ ENDIF
+ 1 CONTINUE
+
+ WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
+ 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
+ & 'operation ',A,/,11X,'and factors ',2E11.4)
+ WRITE(LOUT,1004) CNORM(NORM)
+ 1004 FORMAT(1X,'normalization: ',A,/)
+
+ DO 2 K=1,IBINS(IH1)
+ CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
+ CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
+ XLOW = XLOW1
+ XHI = XHI1
+ XMEAN = OHALF*(XMEAN1+XMEAN2)
+ IF (COPER.EQ.'+') THEN
+ YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
+ ELSEIF (COPER.EQ.'*') THEN
+ YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
+ ELSEIF (COPER.EQ.'/') THEN
+ IF (YMEAN2.EQ.ZERO) THEN
+ YMEAN = ZERO
+ ELSE
+ IF (FAC2.EQ.ZERO) FAC2 = ONE
+ YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
+ ENDIF
+ ELSE
+ GOTO 9998
+ ENDIF
+ WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
+ WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
+ 1006 FORMAT(1X,5E11.3)
+* small frame
+ II = 2*K
+ XX(II-1) = HIST(1,IH1,K)
+ XX(II) = HIST(1,IH1,K+1)
+ YY(II-1) = YMEAN
+ YY(II) = YMEAN
+* wide frame
+ XX1(K) = XMEAN
+ IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
+ YY1(K) = YMEAN
+ 2 CONTINUE
+
+* plot small frame
+ IF (ABS(MODE).EQ.1) THEN
+ IBIN2 = 2*IBINS(IH1)
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ IF(ILOGY.EQ.1) THEN
+ CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
+ ELSE
+ CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
+ ENDIF
+ ENDIF
+
+* plot wide frame
+ IF (ABS(MODE).EQ.2) THEN
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ NSIZE = NDIM
+ DXLOW = HIST(1,IH1,1)
+ DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
+ YLOW = RLARGE
+ YHI = SMALL
+ DO 3 I=1,NDIM
+ IF (YY1(I).LT.YLOW) THEN
+ IF (ILOGY.EQ.1) THEN
+ IF (YY1(I).GT.ZERO) YLOW = YY1(I)
+ ELSE
+ YLOW = YY1(I)
+ ENDIF
+ ENDIF
+ IF (YY1(I).GT.YHI) YHI = YY1(I)
+ 3 CONTINUE
+ DY = (YHI-YLOW)/DBLE(NDIM)
+ IF (DY.LE.ZERO) THEN
+ WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
+ & 'JOIHIS: warning! zero bin width for histograms ',
+ & IH1,IH2,': ',YLOW,YHI
+ RETURN
+ ENDIF
+ IF (ILOGY.EQ.1) THEN
+ YLOW = LOG10(YLOW)
+ DY = (LOG10(YHI)-YLOW)/100.0D0
+ DO 4 I=1,NDIM
+ IF (YY1(I).LE.ZERO) THEN
+ YY1(I) = YLOW
+ ELSE
+ YY1(I) = LOG10(YY1(I))
+ ENDIF
+ 4 CONTINUE
+ ENDIF
+ CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
+ ENDIF
+
+ RETURN
+
+ 9998 CONTINUE
+ WRITE(LOUT,1005) COPER
+ 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
+
+ 9999 CONTINUE
+ RETURN
+ END
+
+*$ CREATE DT_XGRAPH.FOR
+*COPY DT_XGRAPH
+*
+*===qgraph=============================================================*
+*
+ SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
+C***********************************************************************
+C
+C calculate quasi graphic picture with 25 lines and 79 columns
+C ranges will be chosen automatically
+C
+C input N dimension of input fields
+C IARG number of curves (fields) to plot
+C X field of X
+C Y1 field of Y1
+C Y2 field of Y2
+C
+C This subroutine is written by R. Engel.
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C
+ DIMENSION X(N),Y1(N),Y2(N)
+ PARAMETER (EPS=1.D-30)
+ PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
+ CHARACTER SYMB(5)
+ CHARACTER COL(0:149,0:49)
+C
+ DATA SYMB /'0','e','z','#','x'/
+C
+ ISPALT=IBREIT-10
+C
+C*** automatic range fitting
+C
+ XMAX=X(1)
+ XMIN=X(1)
+ DO 600 I=1,N
+ XMAX=MAX(X(I),XMAX)
+ XMIN=MIN(X(I),XMIN)
+ 600 CONTINUE
+ XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
+C
+ ITEST=0
+ DO 1100 K=0,IZEIL-1
+ ITEST=ITEST+1
+ IF (ITEST.EQ.IYRAST) THEN
+ DO 1010 L=1,ISPALT-1
+ COL(L,K)='-'
+1010 CONTINUE
+ COL(ISPALT,K)='+'
+ ITEST=0
+ DO 1020 L=0,ISPALT-1,IXRAST
+ COL(L,K)='+'
+1020 CONTINUE
+ ELSE
+ DO 1030 L=1,ISPALT-1
+ COL(L,K)=' '
+1030 CONTINUE
+ DO 1040 L=0,ISPALT-1,IXRAST
+ COL(L,K)='|'
+1040 CONTINUE
+ COL(ISPALT,K)='|'
+ ENDIF
+1100 CONTINUE
+C
+C*** plot curve Y1
+C
+ YMAX=Y1(1)
+ YMIN=Y1(1)
+ DO 500 I=1,N
+ YMAX=MAX(Y1(I),YMAX)
+ YMIN=MIN(Y1(I),YMIN)
+500 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 550 I=1,N
+ YMAX=MAX(Y2(I),YMAX)
+ YMIN=MIN(Y2(I),YMIN)
+550 CONTINUE
+ ENDIF
+ YMAX=(YMAX-YMIN)/40.0D0+YMAX
+ YMIN=YMIN-(YMAX-YMIN)/40.0D0
+ YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
+ IF(YZOOM.LT.EPS) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+C*** plot curve Y1
+C
+ ILAST=-1
+ LLAST=-1
+ DO 1200 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMAX-Y1(K))/YZOOM)
+ IF(ILAST.GE.0) THEN
+ LD = L-LLAST
+ ID = I-ILAST
+ DO 55 II=0,LD,SIGN(1,LD)
+ DO 66 KK=0,ID,SIGN(1,ID)
+ COL(II+LLAST,KK+ILAST)=SYMB(1)
+ 66 CONTINUE
+ 55 CONTINUE
+ ELSE
+ COL(L,I)=SYMB(1)
+ ENDIF
+ ILAST = I
+ LLAST = L
+1200 CONTINUE
+C
+ IF(IARG.GT.1) THEN
+C
+C*** plot curve Y2
+C
+ DO 1250 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMAX-Y2(K))/YZOOM)
+ COL(L,I)=SYMB(2)
+1250 CONTINUE
+ ENDIF
+C
+C*** write it
+C
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+C
+C*** write range of X
+C
+ XZOOM = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
+C
+ DO 1300 K=0,IZEIL-1
+ YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
+ WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
+ 110 FORMAT(1X,1PE9.2,70A1)
+1300 CONTINUE
+C
+C*** write range of X
+C
+ XZOOM = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+ 120 FORMAT(6X,7(1PE10.3))
+ END
+
+*$ CREATE DT_XGLOGY.FOR
+*COPY DT_XGLOGY
+*
+*===qglogy=============================================================*
+*
+ SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
+C***********************************************************************
+C
+C calculate quasi graphic picture with 25 lines and 79 columns
+C logarithmic y axis
+C ranges will be chosen automatically
+C
+C input N dimension of input fields
+C IARG number of curves (fields) to plot
+C X field of X
+C Y1 field of Y1
+C Y2 field of Y2
+C
+C This subroutine is written by R. Engel.
+C***********************************************************************
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION X(N),Y1(N),Y2(N)
+ PARAMETER (EPS=1.D-30)
+ PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
+ CHARACTER SYMB(5)
+ CHARACTER COL(0:149,0:49)
+ PARAMETER (DEPS = 1.D-10)
+C
+ DATA SYMB /'0','e','z','#','x'/
+C
+ ISPALT=IBREIT-10
+C
+C*** automatic range fitting
+C
+ XMAX=X(1)
+ XMIN=X(1)
+ DO 600 I=1,N
+ XMAX=MAX(X(I),XMAX)
+ XMIN=MIN(X(I),XMIN)
+ 600 CONTINUE
+ XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
+C
+ ITEST=0
+ DO 1100 K=0,IZEIL-1
+ ITEST=ITEST+1
+ IF (ITEST.EQ.IYRAST) THEN
+ DO 1010 L=1,ISPALT-1
+ COL(L,K)='-'
+1010 CONTINUE
+ COL(ISPALT,K)='+'
+ ITEST=0
+ DO 1020 L=0,ISPALT-1,IXRAST
+ COL(L,K)='+'
+1020 CONTINUE
+ ELSE
+ DO 1030 L=1,ISPALT-1
+ COL(L,K)=' '
+1030 CONTINUE
+ DO 1040 L=0,ISPALT-1,IXRAST
+ COL(L,K)='|'
+1040 CONTINUE
+ COL(ISPALT,K)='|'
+ ENDIF
+1100 CONTINUE
+C
+C*** plot curve Y1
+C
+ YMAX=Y1(1)
+ YMIN=MAX(Y1(1),EPS)
+ DO 500 I=1,N
+ YMAX =MAX(Y1(I),YMAX)
+ IF(Y1(I).GT.EPS) THEN
+ IF(YMIN.EQ.EPS) THEN
+ YMIN = Y1(I)/10.D0
+ ELSE
+ YMIN = MIN(Y1(I),YMIN)
+ ENDIF
+ ENDIF
+500 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 550 I=1,N
+ YMAX=MAX(Y2(I),YMAX)
+ IF(Y2(I).GT.EPS) THEN
+ IF(YMIN.EQ.EPS) THEN
+ YMIN = Y2(I)
+ ELSE
+ YMIN = MIN(Y2(I),YMIN)
+ ENDIF
+ ENDIF
+550 CONTINUE
+ ENDIF
+C
+ DO 560 I=1,N
+ Y1(I) = MAX(Y1(I),YMIN)
+ 560 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 570 I=1,N
+ Y2(I) = MAX(Y2(I),YMIN)
+ 570 CONTINUE
+ ENDIF
+C
+ IF(YMAX.LE.YMIN) THEN
+ WRITE(LOUT,'(/1X,A,2E12.3,/)')
+ & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
+ WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+ YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
+ YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
+ YZOOM=(YMA-YMI)/DBLE(IZEIL)
+ IF(YZOOM.LT.EPS) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+C*** plot curve Y1
+C
+ ILAST=-1
+ LLAST=-1
+ DO 1200 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
+ IF(ILAST.GE.0) THEN
+ LD = L-LLAST
+ ID = I-ILAST
+ DO 55 II=0,LD,SIGN(1,LD)
+ DO 66 KK=0,ID,SIGN(1,ID)
+ COL(II+LLAST,KK+ILAST)=SYMB(1)
+ 66 CONTINUE
+ 55 CONTINUE
+ ELSE
+ COL(L,I)=SYMB(1)
+ ENDIF
+ ILAST = I
+ LLAST = L
+1200 CONTINUE
+C
+ IF(IARG.GT.1) THEN
+C
+C*** plot curve Y2
+C
+ DO 1250 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
+ COL(L,I)=SYMB(2)
+1250 CONTINUE
+ ENDIF
+C
+C*** write it
+C
+ WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+C
+C*** write range of X
+C
+ XZOOM1 = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
+C
+ DO 1300 K=0,IZEIL-1
+ YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
+ WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
+ 110 FORMAT(1X,1PE9.2,70A1)
+1300 CONTINUE
+C
+C*** write range of X
+C
+ WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+ 120 FORMAT(6X,7(1PE10.3))
+C
+ END
+
+*$ CREATE DT_SRPLOT.FOR
+*COPY DT_SRPLOT
+*
+*===plot===============================================================*
+*
+ SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+*
+* initial version
+* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
+* This is a subroutine of fluka to plot Y across the page
+* as a function of X down the page. Up to 37 curves can be
+* plotted in the same picture with different plotting characters.
+* Output of first 10 overprinted characters addad by FB 88
+* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+*
+* Input Variables:
+* X = array containing the values of X
+* Y = array containing the values of Y
+* N = number of values in X and in Y
+* can exceed the fixed number of lines
+* M = number of different curves X,Y are containing
+* MM = number of points in each curve i.e. N=M*MM
+* XO = smallest value of X to be plotted
+* DX = increment of X between subsequent lines
+* YO = smallest value of Y to be plotted
+* DY = increment of Y between subsequent character spaces
+*
+* other variables used inside:
+* XX = numbers along the X-coordinate axis
+* YY = numbers along the Y-coordinate axis
+* LL = ten lines temporary storage for the plot
+* L = character set used to plot different curves
+* LOV = memorizes overprinted symbols
+* the first 10 overprinted symbols are printed on
+* the end of the line to avoid ambiguities
+* (added by FB as considered quite helpful)
+*
+*********************************************************************
+*
+ DIMENSION XX(61),YY(61),LL(101,10)
+ DIMENSION X(N),Y(N),L(40),LOV(40,10)
+ DATA L/
+ 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
+ 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
+ 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
+ 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
+*
+*
+ MN=51
+ DO 10 I=1,MN
+ AI=I-1
+ 10 XX(I)=XO+AI*DX
+ DO 20 I=1,11
+ AI=I-1
+ 20 YY(I)=YO+10.0D0*AI*DY
+ WRITE(LOUT, 500) (YY(I),I=1,11)
+ MMN=MN-1
+*
+*
+ DO 90 JJ=1,MMN,10
+ JJJ=JJ-1
+ DO 30 I=1,101
+ DO 30 J=1,10
+ 30 LL(I,J)=L(40)
+ DO 40 I=1,101
+ 40 LL(I,1)=L(39)
+ DO 50 I=1,101,10
+ DO 50 J=1,10
+ 50 LL(I,J)=L(38)
+ DO 60 I=1,40
+ DO 60 J=1,10
+ 60 LOV(I,J)=L(40)
+*
+*
+ DO 70 I=1,M
+ DO 70 J=1,MM
+ II=J+(I-1)*MM
+ AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
+ AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
+ AIX=AIX-DBLE(JJJ)
+* changed Sept.88 by FB to avoid INTEGER OVERFLOW
+ IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
+ + . AIY .LT. 102.D0) THEN
+ IX=INT(AIX)
+ IY=INT(AIY)
+ IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
+ + THEN
+ IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
+ + =LL(IY,IX)
+ LL(IY,IX)=L(I)
+ ENDIF
+ ENDIF
+ 70 CONTINUE
+*
+*
+ DO 80 I=1,10
+ II=I+JJJ
+ III=II+1
+ WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
+ & (LOV(J,I),J=1,10)
+ 80 CONTINUE
+ 90 CONTINUE
+*
+*
+ WRITE(LOUT, 520)
+ WRITE(LOUT, 500) (YY(I),I=1,11)
+ RETURN
+*
+ 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
+ 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
+ 520 FORMAT(20X,10('1---------'),'1')
+ END
+*$ CREATE DT_DEFSET.FOR
+*COPY DT_DEFSET
+*
+*===defset=============================================================*
+*
+ BLOCK DATA DT_DEFSET
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* / DTFLG1 /
+ DATA IFRAG / 2, 1 /
+ DATA IRESCO / 1 /
+ DATA IMSHL / 1 /
+ DATA IRESRJ / 0 /
+ DATA IOULEV / -1, -1, -1, -1, -1, -1 /
+ DATA LEMCCK / .FALSE. /
+ DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
+ & .TRUE.,.TRUE.,.TRUE./
+ DATA LSEADI / .TRUE. /
+ DATA LEVAPO / .TRUE. /
+ DATA IFRAME / 1 /
+ DATA ITRSPT / 0 /
+
+* / DTCOMP /
+ DATA EMUFRA / NCOMPX*0.0D0 /
+ DATA IEMUMA / NCOMPX*1 /
+ DATA IEMUCH / NCOMPX*1 /
+ DATA NCOMPO / 0 /
+ DATA IEMUL / 0 /
+
+ END
+
+*$ CREATE DT_HADPRP.FOR
+*COPY DT_HADPRP
+*
+*===hadprp=============================================================*
+*
+ BLOCK DATA DT_HADPRP
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+
+* names of hadrons used in input-cards
+ CHARACTER*8 BTYPE
+ COMMON /DTPAIN/ BTYPE(30)
+
+* / DTQUAR /
+*----------------------------------------------------------------------*
+* *
+* Quark content of particles: *
+* index quark el. charge bar. charge isospin isospin3 *
+* 1 = u 2/3 1/3 1/2 1/2 *
+* -1 = ubar -2/3 -1/3 1/2 -1/2 *
+* 2 = d -1/3 1/3 1/2 -1/2 *
+* -2 = dbar 1/3 -1/3 1/2 1/2 *
+* 3 = s -1/3 1/3 0 0 *
+* -3 = sbar 1/3 -1/3 0 0 *
+* 4 = c 2/3 1/3 0 0 *
+* -4 = cbar -2/3 -1/3 0 0 *
+* 5 = b -1/3 1/3 0 0 *
+* -5 = bbar 1/3 -1/3 0 0 *
+* 6 = t 2/3 1/3 0 0 *
+* -6 = tbar -2/3 -1/3 0 0 *
+* *
+* Mquark = particle quark composition (Paprop numbering) *
+* Iqechr = electric charge ( in 1/3 unit ) *
+* Iqbchr = baryonic charge ( in 1/3 unit ) *
+* Iqichr = isospin ( in 1/2 unit ), z component *
+* Iqschr = strangeness *
+* Iqcchr = charm *
+* Iquchr = beauty *
+* Iqtchr = ...... *
+* *
+*----------------------------------------------------------------------*
+ DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
+ DATA IQBCHR / 6*-1, 0, 6*1 /
+ DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
+ DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
+ DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
+ DATA IQUCHR / 0, 1, 9*0, -1, 0 /
+ DATA IQTCHR / -1, 11*0, 1 /
+ DATA MQUARK /
+ & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
+ & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
+ & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
+ & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
+ & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
+
+* / DTHAIC /
+* (renamed) (HAdron InDex COnversion)
+* translation table version filled up by r.e. 25.01.94 *
+ DATA IAMCIN /
+ &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
+ &13,130,211,-211,321, -321,3122,-3122,310,3112,
+ &3222,3212,111,311,-311, 0,0,0,0,0,
+ &221,213,113,-213,223, 323,313,-323,-313,10323,
+ &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
+ &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
+ &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
+ &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
+ &5*99999, 5*99999,
+ &4*99999,331, 333,3322,3312,-3222,-3212,
+ &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
+ &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
+ &-431,441,423,413,-413, -423,433,-433,20443,443,
+ &-15,15,16,-16,14, -14,4122,4232,4132,4222,
+ &4212,4112,3*99999, 3*99999,-4122,-4232,
+ &-4132,-4222,-4212,-4112,99999, 5*99999,
+ &5*99999, 5*99999,
+ &10*99999,
+ &5*99999 , 20211,20111,-20211,99999,20321,
+ &-20321,20311,-20311,7*99999 ,
+ &7*99999,12212,12112,99999/
+
+* / DTHAIC /
+* (HAdron InDex COnversion)
+ DATA (IPDG2(1,K),K=1,7)
+ & / -11, -12, -13, -15, -16, -14, 0/
+ DATA (IBAM2(1,K),K=1,7)
+ & / 4, 6, 10, 131, 134, 136, 0/
+ DATA (IPDG2(2,K),K=1,7)
+ & / 11, 12, 22, 13, 15, 16, 14/
+ DATA (IBAM2(2,K),K=1,7)
+ & / 3, 5, 7, 11, 132, 133, 135/
+ DATA (IPDG3(1,K),K=1,22)
+ & / -211, -321, -311, -213, -323, -313, -411, -421,
+ & -431, -413, -423, -433, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0/
+ DATA (IBAM3(1,K),K=1,22)
+ & / 14, 16, 25, 34, 38, 39, 118, 119,
+ & 121, 125, 126, 128, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0/
+ DATA (IPDG3(2,K),K=1,22)
+ & / 130, 211, 321, 310, 111, 311, 221, 213,
+ & 113, 223, 323, 313, 331, 333, 421, 411,
+ & 431, 441, 423, 413, 433, 443/
+ DATA (IBAM3(2,K),K=1,22)
+ & / 12, 13, 15, 19, 23, 24, 31, 32,
+ & 33, 35, 36, 37, 95, 96, 116, 117,
+ & 120, 122, 123, 124, 127, 130/
+ DATA (IPDG4(1,K),K=1,29)
+ & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
+ & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
+ & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
+ & -4212, -4112, 0, 0, 0/
+ DATA (IBAM4(1,K),K=1,29)
+ & / 2, 9, 18, 67, 68, 69, 70, 75,
+ & 76, 99, 100, 101, 102, 103, 110, 111,
+ & 112, 113, 114, 115, 149, 150, 151, 152,
+ & 153, 154, 0, 0, 0/
+ DATA (IPDG4(2,K),K=1,29)
+ & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
+ & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
+ & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
+ & 4232, 4132, 4222, 4212, 4112/
+ DATA (IBAM4(2,K),K=1,29)
+ & / 1, 8, 17, 20, 21, 22, 48, 49,
+ & 50, 51, 52, 53, 54, 55, 56, 97,
+ & 98, 104, 105, 106, 107, 108, 109, 137,
+ & 138, 139, 140, 141, 142/
+ DATA (IPDG5(1,K),K=1,19)
+ & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
+ & -20211,-20321,-20311, 0, 0, 0, 0, 0,
+ & 0, 0, 0/
+ DATA (IBAM5(1,K),K=1,19)
+ & / 42, 43, 46, 47, 71, 72, 73, 74,
+ & 188, 191, 193, 0, 0, 0, 0, 0,
+ & 0, 0, 0/
+ DATA (IPDG5(2,K),K=1,19)
+ & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
+ & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
+ & 20311, 12212, 12112/
+ DATA (IBAM5(2,K),K=1,19)
+ & / 40, 41, 44, 45, 57, 58, 59, 60,
+ & 63, 64, 65, 66, 129, 186, 187, 190,
+ & 192, 208, 209/
+
+* / DTPAIN /
+* internal particle names
+ DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
+ &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
+ &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
+ &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
+ &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
+ &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
+ &'BLANK ' /
+
+ END
+
+*$ CREATE DT_BLKD46.FOR
+*COPY DT_BLKD46
+*
+*===blkd46=============================================================*
+*
+ BLOCK DATA DT_BLKD46
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( AMMUON = 0.105658389 D+00 )
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* / DTPART /
+* Particle masses Engel version JETSET compatible
+C DATA (AAM(K),K=1,85) /
+C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
+C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
+C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
+C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
+C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
+C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
+C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
+C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
+C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
+C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
+C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
+C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
+C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
+C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
+C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
+C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
+C DATA (AAM(K),K=86,183) /
+C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
+C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
+C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
+C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
+C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
+C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
+C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
+C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
+C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
+C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
+C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
+C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
+C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
+C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
+C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
+C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+C & .1250D+01, .1250D+01, .1250D+01 /
+C DATA (AAM ( I ), I = 184,210 ) /
+C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
+C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
+C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
+C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
+C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
+C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
+C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
+* sr 25.1.06: particle masses adjusted to Pythia
+ DATA (AAM(K),K=1,85) /
+ & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
+ & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
+ & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
+ & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
+ & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
+ & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
+ & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
+ & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
+ & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
+ & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
+ & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
+ & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
+ & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
+ & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
+ & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
+ & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
+ & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
+ DATA (AAM(K),K=86,183) /
+ & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
+ & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
+ & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
+ & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
+ & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
+ & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
+ & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
+ & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
+ & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
+ & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
+ & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
+ & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
+ & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
+ & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
+ & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+ & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+ & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+ & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+ & .1250D+01, .1250D+01, .1250D+01 /
+ DATA (AAM ( I ), I = 184,210 ) /
+ & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
+ & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
+ & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
+ & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
+ & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+ & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+ & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
+ & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
+ & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
+* Particle mean lives
+ DATA (TAU(K),K=1,183) /
+ & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
+ & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
+ & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
+ & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
+ & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
+ & 70*.0000D+00,
+ & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
+ & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
+ & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & 40*.0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00 /
+ DATA ( TAU ( I ), I = 184,210 ) /
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
+* Resonance width Gamma in GeV
+ DATA (GA(K),K= 1,85) /
+ & 30*.0000D+00,
+ & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
+ & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
+ & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
+ & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
+ & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
+ & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
+ & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
+ & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
+ & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
+ & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
+ & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
+ DATA (GA(K),K= 86,183) /
+ & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
+ & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
+ & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
+ & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
+ & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
+ & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
+ & 50*.0000D+00,
+ & .3000D+00, .3000D+00, .3000D+00 /
+ DATA ( GA ( I ), I = 184,210 ) /
+ & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
+ & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
+ & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
+ & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
+ & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
+ & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
+ & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
+ & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
+ & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
+* Particle names
+* S+1385+Sigma+(1385) L02030+Lambda0(2030)
+* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
+* designation N*@@ means N*@1(@2)
+ DATA (ANAME(K),K=1,85) /
+ & 'P ','AP ','E- ','E+ ','NUE ',
+ & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
+ & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
+ & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
+ & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
+ & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
+ & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
+ & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
+ & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
+ & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
+ & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
+ & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
+ & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
+ & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
+ & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
+ & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
+ & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
+ DATA (ANAME(K),K=86,183) /
+ & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
+ & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
+ & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
+ & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
+ & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
+ & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
+ & 'D0 ','D+ ','D- ','AD0 ','F+ ',
+ & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
+ & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
+ & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
+ & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
+ & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
+ & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
+ & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
+ & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
+ & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
+ & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
+ & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
+ & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
+ & 'RO ','R+ ','R- ' /
+ DATA ( ANAME ( I ), I = 184,210 ) /
+ &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
+ &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
+ &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
+ &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
+ &'N*+14 ','N*014 ','BLANK '/
+* Charge of particles and resonances
+ DATA (IICH ( I ), I = 1,210 ) /
+ & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
+ & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
+ & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
+ & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
+ & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
+ & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
+ & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
+ & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
+ & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
+ & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
+ & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
+ & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
+ & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
+* Particle baryonic charges
+ DATA (IIBAR ( I ), I = 1,210 ) /
+ & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
+ & 0, 1, -1, 0, 1, 1, 1, 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, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
+ & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
+ & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
+ & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
+ & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
+ & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
+* First number of decay channels used for resonances
+* and decaying particles
+ DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
+ & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
+ & 2*330, 46, 51, 52, 54, 55, 58,
+* 50
+ & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
+ & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
+ & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
+* 85
+ & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
+ & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
+ & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
+ & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
+ & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
+ & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
+ & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
+ & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
+ & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
+ & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
+ & 590, 596, 602 /
+* Last number of decay channels used for resonances
+* and decaying particles
+ DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
+ & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
+ & 2* 330, 50, 51, 53, 54, 57,
+* 50
+ & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
+ & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
+ & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
+* 85
+ & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
+ & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
+ & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
+ & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
+ & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
+ & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
+ & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
+ & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
+ & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
+ & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
+ & 589, 595, 601, 602 /
+
+ END
+
+*$ CREATE DT_BLKD47.FOR
+*COPY DT_BLKD47
+*
+*===blkd47=============================================================*
+*
+ BLOCK DATA DT_BLKD47
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+
+* Name of decay channel
+* Designation N*@ means N*@1(1236)
+* @1=# means ++, @1 = = means --
+* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
+ DATA (ZKNAME(K),K= 1, 85) /
+ & 'P ','AP ','E- ','E+ ','NUE ',
+ & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
+ & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
+ & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
+ & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
+ & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
+ & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
+ & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
+ & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
+ & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
+ & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
+ & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
+ & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
+ & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
+ & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
+ & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
+ & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
+ DATA (ZKNAME(K),K= 86,170) /
+ & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
+ & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
+ & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
+ & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
+ & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
+ & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
+ & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
+ & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
+ & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
+ & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
+ & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
+ & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
+ & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
+ & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
+ & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
+ & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
+ & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
+ DATA (ZKNAME(K),K=171,255) /
+ & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
+ & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
+ & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
+ & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
+ & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
+ & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
+ & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
+ & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
+ & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
+ & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
+ & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
+ & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
+ & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
+ & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
+ & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
+ & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
+ & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
+ DATA (ZKNAME(K),K=256,340) /
+ & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
+ & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
+ & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
+ & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
+ & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
+ & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
+ & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
+ & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
+ & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
+ & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
+ & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
+ & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
+ DATA (ZKNAME(K),K=341,425) /
+ & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
+ & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
+ & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
+ & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
+ & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
+ & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
+ & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
+ & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
+ & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
+ & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
+ & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
+ & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
+ & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
+ & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
+ & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
+ & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
+ & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
+ DATA (ZKNAME(K),K=426,510) /
+ & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
+ & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
+ & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
+ & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
+ & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
+ & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
+ & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
+ & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
+ & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
+ & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
+ & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
+ & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
+ & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
+ & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
+ & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
+ & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
+ & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
+ DATA (ZKNAME(K),K=511,540) /
+ & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
+ & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
+ & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
+ & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
+ & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
+ & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
+ DATA (ZKNAME(I),I=541,602)/
+ & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
+ & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
+ & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
+ & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
+ & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
+ & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
+ & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
+ & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
+ & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
+* Weight of decay channel
+ DATA (WT(K),K= 1, 85) /
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
+ & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
+ & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
+ & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
+ & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
+ & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
+ & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
+ & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
+ & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
+ & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
+ & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
+ & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
+ & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
+ & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
+ & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
+ DATA (WT(K),K= 86,170) /
+ & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
+ & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
+ & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
+ & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
+ & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
+ & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
+ & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
+ & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
+ & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
+ & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
+ & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
+ & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
+ & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
+ & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
+ & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
+ & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
+ DATA (WT(K),K=171,255) /
+ & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
+ & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
+ & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
+ & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
+ & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
+ & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
+ & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
+ & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
+ & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
+ & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
+ & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
+ & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
+ & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
+ & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
+ & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
+ & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
+ & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
+ DATA (WT(K),K=256,340) /
+ & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
+ & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
+ & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
+ & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
+ & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
+ & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
+ & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
+ & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
+ & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
+ & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
+ & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
+ & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
+ DATA (WT(K),K=341,425) /
+ & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
+ & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
+ & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
+ & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
+ & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
+ & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
+ & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
+ & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
+ & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
+ & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
+ & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
+ & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
+ & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
+ & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
+ & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
+ & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
+ DATA (WT(K),K=426,510) /
+ & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
+ & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
+ & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
+ & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
+ & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
+ & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
+ & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
+ & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
+ & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
+ & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
+ & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
+ & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
+ DATA (WT(K),K=511,540) /
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
+ & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
+ & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
+C
+ DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
+ & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
+ & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
+ & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
+ & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
+ & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
+ & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
+* Particle numbers in decay channel
+ DATA (NZK(K,1),K= 1,170) /
+ & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
+ & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
+ & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
+ & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
+ & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
+ & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
+ & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
+ & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
+ & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
+ & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
+ & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
+ & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
+ & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
+ & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
+ & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
+ & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
+ & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
+ DATA (NZK(K,1),K=171,340) /
+ & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
+ & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
+ & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
+ & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
+ & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
+ & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
+ & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
+ & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
+ & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
+ & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
+ & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
+ & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
+ & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
+ & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
+ DATA (NZK(K,1),K=341,510) /
+ & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
+ & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
+ & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
+ & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
+ & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
+ & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
+ & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
+ & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
+ & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
+ & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
+ & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
+ & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
+ & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
+ & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
+ & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
+ & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
+ & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
+ DATA (NZK(K,1),K=511,540) /
+ & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
+ & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
+ & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
+ DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
+ & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
+ & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
+ & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
+ & 55, 8, 1, 8, 8, 54, 55, 210/
+ DATA (NZK(K,2),K= 1,170) /
+ & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
+ & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
+ & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
+ & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
+ & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
+ & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
+ & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
+ & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
+ & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
+ & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
+ & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
+ & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
+ & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
+ & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
+ & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
+ & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
+ & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
+ DATA (NZK(K,2),K=171,340) /
+ & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
+ & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
+ & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
+ & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
+ & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
+ & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
+ & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
+ & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
+ & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
+ & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
+ & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
+ & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
+ & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
+ & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
+ DATA (NZK(K,2),K=341,510) /
+ & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
+ & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
+ & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
+ & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
+ & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
+ & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
+ & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
+ & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
+ & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
+ & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
+ & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
+ & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
+ & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
+ & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
+ & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
+ & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
+ & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
+ DATA (NZK(K,2),K=511,540) /
+ & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
+ & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
+ DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
+ & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
+ & 14, 14, 23, 14, 16, 25,
+ & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
+ & 23, 13, 14, 23, 0 /
+ DATA (NZK(K,3),K= 1,170) /
+ & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
+ & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
+ & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
+ & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
+ & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
+ & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
+ & 110*0 /
+ DATA (NZK(K,3),K=171,340) /
+ & 80*0,
+ & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
+ & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
+ & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
+ & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
+ & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 30*0,
+ & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
+ DATA (NZK(K,3),K=341,510) /
+ & 30*0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
+ & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
+ & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
+ & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
+ & 80*0 /
+ DATA (NZK(K,3),K=511,540) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
+ & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
+ & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
+
+ END
+
+*$ CREATE DT_XHOINI.FOR
+*COPY DT_XHOINI
+*
+*====phoini============================================================*
+*
+ SUBROUTINE DT_XHOINI
+C SUBROUTINE DT_PHOINI
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ RETURN
+ END
+
+*$ CREATE DT_XVENTB.FOR
+*COPY DT_XVENTB
+*
+*====eventb============================================================*
+*
+ SUBROUTINE DT_XVENTB(NCSY,IREJ)
+C SUBROUTINE DT_EVENTB(NCSY,IREJ)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
+ STOP
+
+ END
+
+*$ CREATE DT_XVENT.FOR
+*COPY DT_XVENT
+*
+*===event==============================================================*
+*
+ SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
+C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION PP(4),PT(4)
+
+ RETURN
+ END
+
+*$ CREATE DT_XOHISX.FOR
+*COPY DT_XOHISX
+*
+*===pohisx=============================================================*
+*
+ SUBROUTINE DT_XOHISX(I,X)
+C SUBROUTINE POHISX(I,X)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ RETURN
+ END
+
+*$ CREATE PHO_LHIST.FOR
+*COPY PHO_LHIST
+*
+*===poluhi=============================================================*
+*
+ SUBROUTINE PHO_LHIST(I,X)
+
+**
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ RETURN
+ END
+
+*$ CREATE PDFSET.FOR
+*COPY PDFSET
+*
+C**********************************************************************
+C
+C dummy subroutines, remove to link PDFLIB
+C
+C**********************************************************************
+ SUBROUTINE PDFSET(PARAM,VALUE)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+ END
+
+*$ CREATE STRUCTM.FOR
+*COPY STRUCTM
+*
+ SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ END
+
+*$ CREATE STRUCTP.FOR
+*COPY STRUCTP
+*
+ SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ END
+
+*$ CREATE DT_DIQBRK.FOR
+*COPY DT_DIQBRK
+*
+*===diqbrk=============================================================*
+*
+ SUBROUTINE DT_XIQBRK
+C SUBROUTINE DT_DIQBRK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ STOP 'diquark-breaking not implemeted !'
+
+ RETURN
+ END
+*$ CREATE DT_ELHAIN.FOR
+*COPY DT_ELHAIN
+*
+*===elhain=============================================================*
+*
+ SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
+
+************************************************************************
+* Elastic hadron-hadron scattering. *
+* This is a revised version of the original. *
+* This version dated 03.04.98 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
+ & TINY10=1.0D-10)
+
+ PARAMETER (ENNTHR = 3.5D0)
+ PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
+ & BLOWB=0.05D0,BHIB=0.2D0,
+ & BLOWM=0.1D0, BHIM=2.0D0)
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+C DATA TSLOPE /10.0D0/
+
+ IREJ = 0
+
+ 1 CONTINUE
+
+ PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
+ EKIN = ELAB-AAM(IP)
+* kinematical quantities in cms of the hadrons
+ AMP2 = AAM(IP)**2
+ AMT2 = AAM(IT)**2
+ S = AMP2+AMT2+TWO*ELAB*AAM(IT)
+ ECM = SQRT(S)
+ ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
+ PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
+
+* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
+ IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
+ & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
+* TSAMCS treats pp and np only, therefore change pn into np and
+* nn into pp
+ IF (IT.EQ.1) THEN
+ KPROJ = IP
+ ELSE
+ KPROJ = 8
+ IF (IP.EQ.8) KPROJ = 1
+ ENDIF
+ CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
+ T = TWO*PCM**2*(CTCMS-ONE)
+
+* very crude treatment otherwise: sample t from exponential dist.
+ ELSE
+* momentum transfer t
+ TMAX = TWO*TWO*PCM**2
+ RR = (PLAB-PLOWH)/(PHIH-PLOWH)
+ IF (IIBAR(IP).NE.0) THEN
+ TSLOPE = BLOWB+RR*(BHIB-BLOWB)
+ ELSE
+ TSLOPE = BLOWM+RR*(BHIM-BLOWM)
+ ENDIF
+ FMAX = EXP(-TSLOPE*TMAX)-ONE
+ R = DT_RNDM(RR)
+ T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
+ IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
+ ENDIF
+
+* target hadron in Lab after scattering
+ ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
+ PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
+ IF (PLRH(2).LE.TINY10) THEN
+C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
+ GOTO 1
+ ENDIF
+* projectile hadron in Lab after scattering
+ ELRH(1) = ELAB+AAM(IT)-ELRH(2)
+ PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
+* scattering angle of projectile in Lab
+ CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
+ STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
+ CALL DT_DSFECF(SPLABP,CPLABP)
+* direction cosines of projectile in Lab
+ CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
+ & CXRH(1),CYRH(1),CZRH(1))
+* scattering angle of target in Lab
+ PLLABT = PLAB-CTLABP*PLRH(1)
+ CTLABT = PLLABT/PLRH(2)
+ STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
+* direction cosines of target in Lab
+ CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
+ & CXRH(2),CYRH(2),CZRH(2))
+* fill /HNFSPA/
+ IRH = 2
+ ITRH(1) = IP
+ ITRH(2) = IT
+
+ RETURN
+ END
+
+*$ CREATE DT_TSAMCS.FOR
+*COPY DT_TSAMCS
+*
+*===tsamcs=============================================================*
+*
+ SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
+
+************************************************************************
+* Sampling of cos(theta) for nucleon-proton scattering according to *
+* hetkfa2/bertini parametrization. *
+* This is a revised version of the original (HJM 24/10/88) *
+* This version dated 28.10.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
+ & TINY10=1.0D-10)
+
+ DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
+ DIMENSION PDCI(60),PDCH(55)
+
+ DATA (DCLIN(I),I=1,80) /
+ & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
+ & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
+ & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
+ & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
+ & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
+ & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
+ & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
+ & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
+ & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
+ & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
+ & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
+ & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
+ & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
+ & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
+ & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
+ & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
+ DATA (DCLIN(I),I=81,160) /
+ & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
+ & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
+ & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
+ & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
+ & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
+ & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
+ & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
+ & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
+ & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
+ & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
+ & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
+ & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
+ & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
+ & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
+ & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
+ & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
+ DATA (DCLIN(I),I=161,195) /
+ & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
+ & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
+ & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
+ & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
+ & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
+ & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
+ & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
+
+ DATA PDCI /
+ & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
+ & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
+ & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
+ & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
+ & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
+ & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
+ & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
+ & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
+ & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
+ & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
+ & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
+ & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
+
+ DATA PDCH /
+ & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
+ & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
+ & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
+ & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
+ & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
+ & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
+ & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
+ & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
+ & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
+ & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
+ & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
+
+ DATA (DCHN(I),I=1,90) /
+ & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
+ & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
+ & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
+ & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
+ & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
+ & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
+ & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
+ & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
+ & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
+ & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
+ & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
+ & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
+ & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
+ & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
+ & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
+ & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
+ & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
+ & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
+ DATA (DCHN(I),I=91,143) /
+ & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
+ & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
+ & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
+ & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
+ & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
+ & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
+ & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
+ & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
+ & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
+ & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
+ & 6.488D-02, 6.485D-02, 6.480D-02/
+
+ DATA DCHNA /
+ & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
+ & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
+ & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
+ & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
+ & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
+ & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
+ & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
+ & 1.000D+00/
+
+ DATA DCHNB /
+ & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
+ & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
+ & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
+ & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
+ & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
+ & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
+ & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
+ & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
+ & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
+
+ CST = ONE
+ IF (EKIN.GT.3.5D0) RETURN
+C
+ IF(KPROJ.EQ.8) GOTO 101
+ IF(KPROJ.EQ.1) GOTO 102
+C* INVALID REACTION
+ WRITE(LOUT,'(A,I5/A)')
+ & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
+ & ' COS(THETA) = 1D0 RETURNED'
+ RETURN
+C-------------------------------- NP ELASTIC SCATTERING----------
+101 CONTINUE
+ IF (EKIN.GT.0.740D0)GOTO 1000
+ IF (EKIN.LT.0.300D0)THEN
+C EKIN .LT. 300 MEV
+ IDAT=1
+ ELSE
+C 300 MEV < EKIN < 740 MEV
+ IDAT=6
+ END IF
+C
+ ENER=EKIN
+ IE=INT(ABS(ENER/0.020D0))
+ UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
+C FORWARD/BACKWARD DECISION
+ K=IDAT+5*IE
+ BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
+ IF (DT_RNDM(CST).LT.BWFW)THEN
+ VALUE2=-1D0
+ K=K+1
+ ELSE
+ VALUE2=1D0
+ K=K+3
+ END IF
+C
+ COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
+ RND=DT_RNDM(COEF)
+C
+ IF(RND.LT.COEF)THEN
+ CST=DT_RNDM(RND)
+ CST=CST*VALUE2
+ ELSE
+ R1=DT_RNDM(CST)
+ R2=DT_RNDM(R1)
+ R3=DT_RNDM(R2)
+ R4=DT_RNDM(R3)
+C
+ IF(VALUE2.GT.0.0)THEN
+ CST=MAX(R1,R2,R3,R4)
+ GOTO 1500
+ ELSE
+ R5=DT_RNDM(R4)
+C
+ IF (IDAT.EQ.1)THEN
+ CST=-MAX(R1,R2,R3,R4,R5)
+ ELSE
+ R6=DT_RNDM(R5)
+ R7=DT_RNDM(R6)
+ CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
+ END IF
+C
+ END IF
+C
+ END IF
+C
+ GOTO 1500
+C
+C******** EKIN .GT. 0.74 GEV
+C
+1000 ENER=EKIN - 0.66D0
+C IE=ABS(ENER/0.02)
+ IE=INT(ENER/0.02D0)
+ EMEV=EKIN*1D3
+C
+ UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
+ K=IE
+ BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
+ RND=DT_RNDM(BWFW)
+C FORWARD NEUTRON
+ IF (RND.GE.BWFW)THEN
+ DO 1200 K=10,36,9
+ IF (DCHNA(K).GT.EMEV) THEN
+ UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
+ UNIV=DT_RNDM(UNIVE)
+ DO 1100 I=1,8
+ II=K+I
+ P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
+C
+ IF (P.GT.UNIV)THEN
+ UNIV=DT_RNDM(UNIVE)
+ FLTI=DBLE(I)-UNIV
+ GOTO(290,290,290,290,330,340,350,360) I
+ END IF
+ 1100 CONTINUE
+ END IF
+ 1200 CONTINUE
+C
+ ELSE
+C BACKWARD NEUTRON
+ DO 1400 K=13,60,12
+ IF (DCHNB(K).GT.EMEV) THEN
+ UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
+ UNIV=DT_RNDM(UNIVE)
+ DO 1300 I=1,11
+ II=K+I
+ P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
+C
+ IF (P.GT.UNIV)THEN
+ UNIV=DT_RNDM(P)
+ FLTI=DBLE(I)-UNIV
+ GOTO(120,120,140,150,160,160,180,190,200,210,220) I
+ END IF
+ 1300 CONTINUE
+ END IF
+ 1400 CONTINUE
+ END IF
+C
+120 CST=1.0D-2*FLTI-1.0D0
+ GOTO 1500
+140 CST=2.0D-2*UNIV-0.98D0
+ GOTO 1500
+150 CST=4.0D-2*UNIV-0.96D0
+ GOTO 1500
+160 CST=6.0D-2*FLTI-1.16D0
+ GOTO 1500
+180 CST=8.0D-2*UNIV-0.80D0
+ GOTO 1500
+190 CST=1.0D-1*UNIV-0.72D0
+ GOTO 1500
+200 CST=1.2D-1*UNIV-0.62D0
+ GOTO 1500
+210 CST=2.0D-1*UNIV-0.50D0
+ GOTO 1500
+220 CST=3.0D-1*(UNIV-1.0D0)
+ GOTO 1500
+C
+290 CST=1.0D0-2.5d-2*FLTI
+ GOTO 1500
+330 CST=0.85D0+0.5D-1*UNIV
+ GOTO 1500
+340 CST=0.70D0+1.5D-1*UNIV
+ GOTO 1500
+350 CST=0.50D0+2.0D-1*UNIV
+ GOTO 1500
+360 CST=0.50D0*UNIV
+C
+1500 RETURN
+C
+C----------------------------------- PP ELASTIC SCATTERING -------
+C
+ 102 CONTINUE
+ EMEV=EKIN*1D3
+C
+ IF (EKIN.LE.0.500D0) THEN
+ RND=DT_RNDM(EMEV)
+ CST=2.0D0*RND-1.0D0
+ RETURN
+C
+ ELSEIF (EKIN.LT.1.0D0) THEN
+ DO 2200 K=13,60,12
+ IF (PDCI(K).GT.EMEV) THEN
+ UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
+ UNIV=DT_RNDM(UNIVE)
+ SUM=0
+ DO 2100 I=1,11
+ II=K+I
+ SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
+C
+ IF (UNIV.LT.SUM)THEN
+ UNIV=DT_RNDM(SUM)
+ FLTI=DBLE(I)-UNIV
+ GOTO(55,55,55,60,60,65,65,65,65,70,70) I
+ END IF
+ 2100 CONTINUE
+ END IF
+ 2200 CONTINUE
+ ELSE
+ DO 2400 K=12,55,11
+ IF (PDCH(K).GT.EMEV) THEN
+ UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
+ UNIV=DT_RNDM(UNIVE)
+ SUM=0.0D0
+ DO 2300 I=1,10
+ II=K+I
+ SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
+C
+ IF (UNIV.LT.SUM)THEN
+ UNIV=DT_RNDM(SUM)
+ FLTI=UNIV+DBLE(I)
+ GOTO(50,55,60,60,65,65,65,65,70,70) I
+ END IF
+ 2300 CONTINUE
+ END IF
+ 2400 CONTINUE
+ END IF
+C
+50 CST=0.4D0*UNIV
+ GOTO 2500
+55 CST=0.2D0*FLTI
+ GOTO 2500
+60 CST=0.3D0+0.1D0*FLTI
+ GOTO 2500
+65 CST=0.6D0+0.04D0*FLTI
+ GOTO 2500
+70 CST=0.78D0+0.02D0*FLTI
+C
+2500 CONTINUE
+ IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
+C
+ RETURN
+ END
+
+*$ CREATE DT_DHADRI.FOR
+*COPY DT_DHADRI
+*
+*===dhadri=============================================================*
+*
+ SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C
+C-----------------------------
+C*** INPUT VARIABLES LIST:
+C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
+C*** GEV/C LABORATORY MOMENTUM REGION
+C*** N - PROJECTILE HADRON INDEX
+C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
+C*** ELAB - LABORATORY ENERGY OF N (GEV)
+C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
+C*** ITTA - TARGET NUCLEON INDEX
+C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
+C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
+C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
+C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
+C*** RESPECT., UNITS (GEV/C AND GEV)
+C----------------------------
+
+ COMMON /HNGAMR/ REDU,AMO,AMM(15)
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+
+ COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
+ & ITS(149),IS
+
+ COMMON /HNDRUN/ RUNTES,EFTES
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+ DIMENSION ITPRF(110)
+ DATA NNN/0/
+ DATA UMODA/0./
+ DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
+ LOWP=0
+ IF (N.LE.0.OR.N.GE.111)N=1
+ IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
+ GOTO 280
+* WRITE (6,1000)
+* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
+* STOP
+*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
+* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
+ ENDIF
+ IATMPT=0
+ IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
+C IF(IPRI.GE.1) WRITE (6,1010) PLAB
+C STOP
+ 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
+ + ALLOWED REGION, PLAB=',1E15.5)
+
+ 20 CONTINUE
+ UMODAT=N*1.11111D0+ITTA*2.19291D0
+ IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
+ UMODA=UMODAT
+ 30 IATMPT=0
+ LOWP=LOWP+1
+ 40 CONTINUE
+ IMACH=0
+ REDU=2.0D0
+ IF (LOWP.GT.20) THEN
+C WRITE(LOUT,*) ' jump 1'
+ GO TO 280
+ ENDIF
+ NNN=N
+ IF (NNN.EQ.N) GO TO 50
+ RUNTES=0.0D0
+ EFTES=0.0D0
+ 50 CONTINUE
+ IS=1
+ IRH=0
+ IST=1
+ NSTAB=23
+ IRE=NURE(N,1)
+ IF(ITTA.GT.1) IRE=NURE(N,2)
+C
+C-----------------------------
+C*** IE,AMT,ECM,SI DETERMINATION
+C----------------------------
+ CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
+ IANTH=-1
+**sr
+C IF (AMH(1).NE.0.93828D0) IANTH=1
+ IF (AMH(1).NE.0.9383D0) IANTH=1
+**
+ IF (IANTH.GE.0) SI=1.0D0
+ ECMMH=ECM
+C
+C-----------------------------
+C ENERGY INDEX
+C IRE CHARACTERIZES THE REACTION
+C IE IS THE ENERGY INDEX
+C----------------------------
+ IF (SI.LT.1.D-6) THEN
+C WRITE(LOUT,*) ' jump 2'
+ GO TO 280
+ ENDIF
+ IF (N.LE.NSTAB) GO TO 60
+ RUNTES=RUNTES+1.0D0
+ IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
+ 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
+ IF(IBARH(N).EQ.1) N=8
+ IF(IBARH(N).EQ.-1) N=9
+ 60 CONTINUE
+ IMACH=IMACH+1
+**sr 19.2.97: loop for direct channel suppression
+C IF (IMACH.GT.10) THEN
+ IF (IMACH.GT.1000) THEN
+**
+C WRITE(LOUT,*) ' jump 3'
+ GO TO 280
+ ENDIF
+ ECM =ECMMH
+ AMN2=AMN**2
+ AMT2=AMT**2
+ ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
+ IF(ECMN.LE.AMN) ECMN=AMN
+ PCMN=SQRT(ECMN**2-AMN2)
+ GAM=(ELAB+AMT)/ECM
+ BGAM=PLAB/ECM
+ IF (IANTH.GE.0) ECM=2.1D0
+C
+C-----------------------------
+C*** RANDOM CHOICE OF REACTION CHANNEL
+C----------------------------
+ IST=0
+ VV=DT_RNDM(AMN2)
+ VV=VV-1.D-17
+C
+C-----------------------------
+C*** PLACE REDUCED VERSION
+C----------------------------
+ IIEI=IEII(IRE)
+ IDWK=IEII(IRE+1)-IIEI
+ IIWK=IRII(IRE)
+ IIKI=IKII(IRE)
+C
+C-----------------------------
+C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
+C----------------------------
+ HECM=ECM
+ HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
+ IF (HUMO.LT.ECM) ECM=HUMO
+C
+C-----------------------------
+C*** INTERPOLATION PREPARATION
+C----------------------------
+ ECMO=UMO(IE)
+ ECM1=UMO(IE-1)
+ DECM=ECMO-ECM1
+ DEC=ECMO-ECM
+C
+C-----------------------------
+C*** RANDOM LOOP
+C----------------------------
+ IK=0
+ WKK=0.0D0
+ WICOR=0.0D0
+ 70 IK=IK+1
+ IWK=IIWK+(IK-1)*IDWK+IE-IIEI
+ WOK=WK(IWK)
+ WDK=WOK-WK(IWK-1)
+C
+C-----------------------------
+C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
+C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
+C CONTRIBUTE
+C----------------------------
+ IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
+ WICO=WOK*1.23459876D0+WDK*1.735218469D0
+ IF (WICO.EQ.WICOR) GO TO 70
+ IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
+ WICOR=WICO
+C
+C-----------------------------
+C*** INTERPOLATION IN CHANNEL WEIGHTS
+C----------------------------
+ EKLIM=-THRESH(IIKI+IK)
+ IELIM=IDT_IEFUND(EKLIM,IRE)
+ DELIM=UMO(IELIM)+EKLIM
+ *+1.D-16
+ DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
+ IF (DELIM*DELIM-DETE*DETE) 90,90,80
+ 80 DECC=DELIM
+ GO TO 100
+ 90 DECC=DECM
+ 100 CONTINUE
+ WKK=WOK-WDK*DEC/(DECC+1.D-9)
+C
+C-----------------------------
+C*** RANDOM CHOICE
+C----------------------------
+C
+ IF (VV.GT.WKK) GO TO 70
+C
+C***IK IS THE REACTION CHANNEL
+C----------------------------
+ INRK=IKII(IRE)+IK
+ ECM=HECM
+ I1001 =0
+C
+ 110 CONTINUE
+ IT1=NRK(1,INRK)
+ AM1=DT_DAMG(IT1)
+ IT2=NRK(2,INRK)
+ AM2=DT_DAMG(IT2)
+ AMS=AM1+AM2
+ I1001=I1001+1
+ IF (I1001.GT.50) GO TO 60
+C
+ IF (IT2*AMS.GT.IT2*ECM) GO TO 110
+ IT11=IT1
+ IT22=IT2
+ IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
+ AM11=AM1
+ AM22=AM2
+ IF (IT2.GT.0) GO TO 120
+**sr 19.2.97: supress direct channel for pp-collisions
+ IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
+ RR = DT_RNDM(AM11)
+ IF (RR.LE.0.75D0) GOTO 60
+ ENDIF
+**
+C
+C-----------------------------
+C INCLUSION OF DIRECT RESONANCES
+C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
+C------------------------
+ KZ1=K1H(IT1)
+ IST=IST+1
+ IECO=0
+ ECO=ECM
+ GAM=(ELAB+AMT)/ECO
+ BGAM=PLAB/ECO
+ CXS(1)=CX
+ CYS(1)=CY
+ CZS(1)=CZ
+ GO TO 170
+ 120 CONTINUE
+ WW=DT_RNDM(ECO)
+ IF(WW.LT. 0.5D0) GO TO 130
+ IT1=IT22
+ IT2=IT11
+ AM1=AM22
+ AM2=AM11
+ 130 CONTINUE
+C
+C-----------------------------
+C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
+ IBN=IBARH(N)
+ IB1=IBARH(IT1)
+ IT11=IT1
+ IT22=IT2
+ AM11=AM1
+ AM22=AM2
+ IF(IB1.EQ.IBN) GO TO 140
+ IT1=IT22
+ IT2=IT11
+ AM1=AM22
+ AM2=AM11
+ 140 CONTINUE
+C-----------------------------
+C***IT1,IT2 ARE THE CREATED PARTICLES
+C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
+C------------------------
+ CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
+ *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
+ IST=IST+1
+ ITS(IST)=IT1
+ AMM(IST)=AM1
+C
+C-----------------------------
+C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
+C----------------------------
+ CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
+ &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IST=IST+1
+ ITS(IST)=IT2
+ AMM(IST)=AM2
+ CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
+ *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ 150 CONTINUE
+C
+C-----------------------------
+C***TEST STABLE OR UNSTABLE
+C----------------------------
+ IF(ITS(IST).GT.NSTAB) GO TO 160
+ IRH=IRH+1
+C
+C-----------------------------
+C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
+C----------------------------
+C* IF (REDU.LT.0.D0) GO TO 1009
+ ITRH(IRH)=ITS(IST)
+ PLRH(IRH)=PLS(IST)
+ CXRH(IRH)=CXS(IST)
+ CYRH(IRH)=CYS(IST)
+ CZRH(IRH)=CZS(IST)
+ ELRH(IRH)=ELS(IST)
+ IST=IST-1
+ IF(IST.GE.1) GO TO 150
+ GO TO 260
+ 160 CONTINUE
+C
+C RANDOM CHOICE OF DECAY CHANNELS
+C----------------------------
+C
+ IT=ITS(IST)
+ ECO=AMM(IST)
+ GAM=ELS(IST)/ECO
+ BGAM=PLS(IST)/ECO
+ IECO=0
+ KZ1=K1H(IT)
+ 170 CONTINUE
+ IECO=IECO+1
+ VV=DT_RNDM(GAM)
+ VV=VV-1.D-17
+ IIK=KZ1-1
+ 180 IIK=IIK+1
+ IF (VV.GT.WTI(IIK)) GO TO 180
+C
+C IIK IS THE DECAY CHANNEL
+C----------------------------
+ IT1=NZKI(IIK,1)
+ I310=0
+ 190 CONTINUE
+ I310=I310+1
+ AM1=DT_DAMG(IT1)
+ IT2=NZKI(IIK,2)
+ AM2=DT_DAMG(IT2)
+ IF (IT2-1.LT.0) GO TO 240
+ IT3=NZKI(IIK,3)
+ AM3=DT_DAMG(IT3)
+ AMS=AM1+AM2+AM3
+C
+C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
+C----------------------------
+ IF (IECO.LE.10) GO TO 200
+ IATMPT=IATMPT+1
+ IF(IATMPT.GT.3) THEN
+C WRITE(LOUT,*) ' jump 4'
+ GO TO 280
+ ENDIF
+ GO TO 40
+ 200 CONTINUE
+ IF (I310.GT.50) GO TO 170
+ IF (AMS.GT.ECO) GO TO 190
+C
+C FOR THE DECAY CHANNEL
+C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
+C----------------------------
+ IF (REDU.LT.0.D0) GO TO 30
+ ITWTHC=0
+ REDU=2.0D0
+ IF(IT3.EQ.0) GO TO 220
+ 210 CONTINUE
+ ITWTH=1
+ CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
+ *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
+ GO TO 230
+ 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
+ &COD2,COF2,SIF2,AM1,AM2)
+ ITWTH=-1
+ IT3=0
+ 230 CONTINUE
+ ITWTHC=ITWTHC+1
+ IF (REDU.GT.0.D0) GO TO 240
+ REDU=2.0D0
+ IF (ITWTHC.GT.100) GO TO 30
+ IF (ITWTH) 220,220,210
+ 240 CONTINUE
+ ITS(IST )=IT1
+ IF (IT2-1.LT.0) GO TO 250
+ ITS(IST+1) =IT2
+ ITS(IST+2)=IT3
+ RX=CXS(IST)
+ RY=CYS(IST)
+ RZ=CZS(IST)
+ AMM(IST)=AM1
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IST=IST+1
+ AMM(IST)=AM2
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IF (IT3.LE.0) GO TO 250
+ IST=IST+1
+ AMM(IST)=AM3
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ 250 CONTINUE
+ GO TO 150
+ 260 CONTINUE
+ 270 CONTINUE
+ RETURN
+ 280 CONTINUE
+C
+C----------------------------
+C
+C ZERO CROSS SECTION CASE
+C----------------------------
+C
+ IRH=1
+ ITRH(1)=N
+ CXRH(1)=CX
+ CYRH(1)=CY
+ CZRH(1)=CZ
+ ELRH(1)=ELAB
+ PLRH(1)=PLAB
+ RETURN
+ END
+
+*$ CREATE DT_RUNTT.FOR
+*COPY DT_RUNTT
+*
+*===runtt==============================================================*
+*
+ BLOCK DATA DT_RUNTT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /HNDRUN/ RUNTES,EFTES
+
+ DATA RUNTES,EFTES /100.D0,100.D0/
+
+ END
+
+*$ CREATE DT_NONAME.FOR
+*COPY DT_NONAME
+*
+*===noname=============================================================*
+*
+ BLOCK DATA DT_NONAME
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* slope parameters for HADRIN interactions
+ COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+C DATAS DATAS DATAS DATAS DATAS
+C****** *********
+ DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
+ & 207, 224, 241, 252, 268 /
+ DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
+ & 220, 241, 262, 279, 296 /
+ DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
+ & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
+
+C
+C MASSES FOR THE SLOPE B(M) IN GEV
+C SLOPE B(M) FOR AN MESONIC SYSTEM
+C SLOPE B(M) FOR A BARYONIC SYSTEM
+
+*
+ DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
+ & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
+ & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
+ & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
+ & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
+ & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
+ & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
+ & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
+ & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
+ & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
+ & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
+ & 14.2D0, 13.4D0, 12.6D0,
+ & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
+ & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
+*
+ END
+
+*$ CREATE DT_DAMG.FOR
+*COPY DT_DAMG
+*
+*===damg===============================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DAMG(IT)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ DIMENSION GASUNI(14)
+ DATA GASUNI/
+ *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
+ *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
+ DATA GAUNO/2.352D0/
+ DATA GAUNON/2.4D0/
+ DATA IO/14/
+ DATA NSTAB/23/
+
+ I=1
+ IF (IT.LE.0) GO TO 30
+ IF (IT.LE.NSTAB) GO TO 20
+ DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
+ VV=DT_RNDM(DGAUNI)
+ VV=VV*2.0D0-1.0D0+1.D-16
+ 10 CONTINUE
+ VO=GASUNI(I)
+ I=I+1
+ V1=GASUNI(I)
+ IF (VV.GT.V1) GO TO 10
+ UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
+ & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
+ DAM=GAH(IT)*UNIGA/GAUNO
+ AAM=AMH(IT)+DAM
+ DT_DAMG=AAM
+ RETURN
+ 20 CONTINUE
+ DT_DAMG=AMH(IT)
+ RETURN
+ 30 CONTINUE
+ DT_DAMG=0.0D0
+ RETURN
+ END
+
+*$ CREATE DT_DCALUM.FOR
+*COPY DT_DCALUM
+*
+*===dcalum=============================================================*
+*
+ SUBROUTINE DT_DCALUM(N,ITTA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IRE=NURE(N,ITTA/8+1)
+ IEO=IEII(IRE)+1
+ IEE=IEII(IRE +1)
+ AM1=AMH(N )
+ AM12=AM1**2
+ AM2=AMH(ITTA)
+ AM22=AM2**2
+ DO 10 IE=IEO,IEE
+ PLAB2=PLABF(IE)**2
+ ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
+ UMO(IE)=ELAB
+ 10 CONTINUE
+ IKO=IKII(IRE)+1
+ IKE=IKII(IRE +1)
+ UMOO=UMO(IEO)
+ DO 30 IK=IKO,IKE
+ IF(NRK(2,IK).GT.0) GO TO 30
+ IKI=NRK(1,IK)
+ AMSS=5.0D0
+ K11=K1H(IKI)
+ K22=K2H(IKI)
+ DO 20 IK1=K11,K22
+ IN=NZKI(IK1,1)
+ AMS=AMH(IN)
+ IN=NZKI(IK1,2)
+ IF(IN.GT.0)AMS=AMS+AMH(IN)
+ IN=NZKI(IK1,3)
+ IF(IN.GT.0) AMS=AMS+AMH(IN)
+ IF (AMS.LT.AMSS) AMSS=AMS
+ 20 CONTINUE
+ IF(UMOO.LT.AMSS) UMOO=AMSS
+ THRESH(IK)=UMOO
+ 30 CONTINUE
+ RETURN
+ END
+
+*$ CREATE DT_DCHANH.FOR
+*COPY DT_DCHANH
+*
+*===dchanh=============================================================*
+*
+ SUBROUTINE DT_DCHANH
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ DIMENSION HWT(460),HWK(40),SI(5184)
+ EQUIVALENCE (WK(1),SI(1))
+C--------------------
+C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
+C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
+C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
+C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
+C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
+C--------------------------
+ IREG=16
+ DO 90 IRE=1,IREG
+ IWKO=IRII(IRE)
+ IEE=IEII(IRE+1)-IEII(IRE)
+ IKE=IKII(IRE+1)-IKII(IRE)
+ IEO=IEII(IRE)+1
+ IIKA=IKII(IRE)
+* modifications to suppress elestic scattering 24/07/91
+ DO 80 IE=1,IEE
+ SIS=1.D-14
+ SINORC=0.0D0
+ DO 10 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
+ SIS=SIS+SI(IWK)*SINORC
+ 10 CONTINUE
+ SIIN(IEO+IE-1)=SIS
+ SIO=0.D0
+ IF (SIS.GE.1.D-12) GO TO 20
+ SIS=1.D0
+ SIO=1.D0
+ 20 CONTINUE
+ SINORC=0.0D0
+ DO 30 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
+ SIO=SIO+SI(IWK)*SINORC/SIS
+ HWK(IK)=SIO
+ 30 CONTINUE
+ DO 40 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ 40 WK(IWK)=HWK(IK)
+ IIKI=IKII(IRE)
+ DO 70 IK=1,IKE
+ AM111=0.D0
+ INRK1=NRK(1,IIKI+IK)
+ IF (INRK1.GT.0) AM111=AMH(INRK1)
+ AM222=0.D0
+ INRK2=NRK(2,IIKI+IK)
+ IF (INRK2.GT.0) AM222=AMH(INRK2)
+ THRESH(IIKI+IK)=AM111 +AM222
+ IF (INRK2-1.GE.0) GO TO 60
+ INRKK=K1H(INRK1)
+ AMSS=5.D0
+ INRKO=K2H(INRK1)
+ DO 50 INRK1=INRKK,INRKO
+ INZK1=NZKI(INRK1,1)
+ INZK2=NZKI(INRK1,2)
+ INZK3=NZKI(INRK1,3)
+ IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
+ IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
+ IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
+C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
+ 1000 FORMAT (4I10)
+ AMS=AMH(INZK1)+AMH(INZK2)
+ IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
+ IF (AMSS.GT.AMS) AMSS=AMS
+ 50 CONTINUE
+ AMS=AMSS
+ IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
+ THRESH(IIKI+IK)=AMS
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ DO 100 J=1,460
+ 100 HWT(J)=0.D0
+ DO 120 I=1,110
+ IK1=K1H(I)
+ IK2=K2H(I)
+ HV=0.D0
+ IF (IK2.GT.460)IK2=460
+ IF (IK1.LE.0)IK1=1
+ DO 110 J=IK1,IK2
+ HV=HV+WTI(J)
+ HWT(J)=HV
+ JI=J
+ 110 CONTINUE
+ IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
+ 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
+ 120 CONTINUE
+ DO 130 J=1,460
+ 130 WTI(J)=HWT(J)
+ RETURN
+ END
+
+*$ CREATE DT_DHADDE.FOR
+*COPY DT_DHADDE
+*
+*===dhadde=============================================================*
+*
+ SUBROUTINE DT_DHADDE
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle properties (BAMJET index convention)
+ CHARACTER*8 ANAME
+ COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+ & IICH(210),IIBAR(210),K1(210),K2(210)
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+
+* decay channel information for HADRIN
+ COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
+ & K1Z(16),K2Z(16),WTZ(153),II22,
+ & NZK1(153),NZK2(153),NZK3(153)
+
+ DATA IRETUR/0/
+
+ IRETUR=IRETUR+1
+ AMH(31)=0.48D0
+ IF (IRETUR.GT.1) RETURN
+ DO 10 I=1,94
+ AMH(I) = AAM(I)
+ GAH(I) = GA(I)
+ TAUH(I) = TAU(I)
+ ICHH(I) = IICH(I)
+ IBARH(I) = IIBAR(I)
+ K1H(I) = K1(I)
+ K2H(I) = K2(I)
+ 10 CONTINUE
+**sr
+C AMH(1)=0.93828D0
+ AMH(1)=0.9383D0
+**
+ AMH(2)=AMH(1)
+ DO 20 I=26,30
+ K1H(I)=452
+ K2H(I)=452
+ 20 CONTINUE
+ DO 30 I=1,307
+ WTI(I) = WT(I)
+ NZKI(I,1) = NZK(I,1)
+ NZKI(I,2) = NZK(I,2)
+ NZKI(I,3) = NZK(I,3)
+ 30 CONTINUE
+ DO 40 I=1,16
+ L=I+94
+ AMH(L)=AMZ(I)
+ GAH( L)=GAZ(I)
+ TAUH( L)=TAUZ(I)
+ ICHH( L)=ICHZ(I)
+ IBARH( L)=IBARZ(I)
+ K1H( L)=K1Z(I)
+ K2H( L)=K2Z(I)
+ 40 CONTINUE
+ DO 50 I=1,153
+ L=I+307
+ WTI(L) = WTZ(I)
+ NZKI(L,3) = NZK3(I)
+ NZKI(L,2) = NZK2(I)
+ NZKI(L,1) = NZK1(I)
+ 50 CONTINUE
+ RETURN
+ END
+
+*$ CREATE IDT_IEFUND.FOR
+*COPY IDT_IEFUND
+*
+*===iefund=============================================================*
+*
+ INTEGER FUNCTION IDT_IEFUND(PL,IRE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C*****IEFUN CALCULATES A MOMENTUM INDEX
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ COMMON /HNDRUN/ RUNTES,EFTES
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IPLA=IEII(IRE)+1
+ *+1
+ IPLE=IEII(IRE+1)
+ IF (PL.LT.0.) GO TO 30
+ DO 10 I=IPLA,IPLE
+ J=I-IPLA+1
+ IF (PL.LE.PLABF(I)) GO TO 60
+ 10 CONTINUE
+ I=IPLE
+ IF ( EFTES.GT.40.D0) GO TO 20
+ EFTES=EFTES+1.0D0
+ WRITE(LOUT,1000)PL,J
+ 20 CONTINUE
+ GO TO 70
+ 30 CONTINUE
+ DO 40 I=IPLA,IPLE
+ J=I-IPLA+1
+ IF (-PL.LE.UMO(I)) GO TO 60
+ 40 CONTINUE
+ I=IPLE
+ IF ( EFTES.GT.40.D0) GO TO 50
+ EFTES=EFTES+1.0D0
+ WRITE(LOUT,1000)PL,I
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ IDT_IEFUND=I
+ RETURN
+ 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
+ +7H IEFUN=,I5)
+ END
+
+*$ CREATE DT_DSIGIN.FOR
+*COPY DT_DSIGIN
+*
+*===dsigin=============================================================*
+*
+ SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IE=IDT_IEFUND(PLAB,IRE)
+ IF (IE.LE.IEII(IRE)) IE=IE+1
+ AMT=AMH(ITAR)
+ AMN=AMH(N)
+ AMN2=AMN*AMN
+ AMT2=AMT*AMT
+ ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
+C*** INTERPOLATION PREPARATION
+ ECMO=UMO(IE)
+ ECM1=UMO(IE-1)
+ DECM=ECMO-ECM1
+ DEC=ECMO-ECM
+ IIKI=IKII(IRE)+1
+ EKLIM=-THRESH(IIKI)
+ WOK=SIIN(IE)
+ WDK=WOK-SIIN(IE-1)
+ IF (ECM.GT.ECMO) WDK=0.0D0
+C*** INTERPOLATION IN CHANNEL WEIGHTS
+ IELIM=IDT_IEFUND(EKLIM,IRE)
+ DELIM=UMO(IELIM)+EKLIM
+ *+1.D-16
+ DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
+ IF (DELIM*DELIM-DETE*DETE) 20,20,10
+ 10 DECC=DELIM
+ GO TO 30
+ 20 DECC=DECM
+ 30 CONTINUE
+ WKK=WOK-WDK*DEC/(DECC+1.D-9)
+ IF (WKK.LT.0.0D0) WKK=0.0D0
+ SI=WKK+1.D-12
+ IF (-EKLIM.GT.ECM) SI=1.D-14
+ RETURN
+ END
+
+*$ CREATE DT_DTCHOI.FOR
+*COPY DT_DTCHOI
+*
+*===dtchoi=============================================================*
+*
+ SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C ****************************
+C TCHOIC CALCULATES A RANDOM VALUE
+C FOR THE FOUR-MOMENTUM-TRANSFER T
+C ****************************
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+* slope parameters for HADRIN interactions
+ COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
+
+ AMA=AM1
+ AMB=AM2
+ IF (I.GT.30.AND.II.GT.30) GO TO 20
+ III=II
+ AM3=AM2
+ IF (I.LE.30) GO TO 10
+ III=I
+ AM3=AM1
+ 10 CONTINUE
+ GO TO 30
+ 20 CONTINUE
+ III=II
+ AM3=AM2
+ IF (AMA.LE.AMB) GO TO 30
+ III=I
+ AM3=AM1
+ 30 CONTINUE
+ IB=IBARH(III)
+ AMA=AM3
+ K=INT((AMA-0.75D0)/0.05D0)
+ IF (K-2.LT.0) K=1
+ IF (K-26.GE.0) K=25
+ IF (IB)50,40,50
+ 40 BM=BBM(K)
+ GO TO 60
+ 50 BM=BBB(K)
+ 60 CONTINUE
+C NORMALIZATION
+ TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
+ TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
+ VB=DT_RNDM(TMIN)
+**sr test
+C IF (VB.LT.0.2D0) BM=BM*0.1
+C **0.5
+ BM = BM*5.05D0
+**
+ TMI=BM*TMIN
+ TMA=BM*TMAX
+ ETMA=0.D0
+ IF (ABS(TMA).GT.120.D0) GO TO 70
+ ETMA=EXP(TMA)
+ 70 CONTINUE
+ AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
+C*** RANDOM CHOICE OF THE T - VALUE
+ R=DT_RNDM(TMI)
+ T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
+ RETURN
+ END
+
+*$ CREATE DT_DTWOPA.FOR
+*COPY DT_DTWOPA
+*
+*===dtwopa=============================================================*
+*
+ SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
+ &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C ******************************************************
+C QUASI TWO PARTICLE PRODUCTION
+C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
+C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
+C IN THE CM - SYSTEM
+C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
+C SPHERICAL COORDINATES
+C ******************************************************
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ AMA=AM1
+ AMB=AM2
+ AMA2=AMA*AMA
+ E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
+ E2=UMOO - E1
+ IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
+ AMTE=(E1-AMA)*(E1+AMA)
+ AMTE=AMTE+1.D-18
+ P1=SQRT(AMTE)
+ P2=P1
+C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
+C DETERMINATION OF THE ANGLES
+C COS(THETA1)=COD1 COS(THETA2)=COD2
+C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
+C COS(PHI1)=COF1 COS(PHI2)=COF2
+C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
+ CALL DT_DSFECF(COF1,SIF1)
+ COF2=-COF1
+ SIF2=-SIF1
+C CALCULATION OF THETA1
+ CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
+ COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
+ IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
+ COD2=-COD1
+ RETURN
+ END
+
+*$ CREATE DT_ZK.FOR
+*COPY DT_ZK
+*
+*===zk=================================================================*
+*
+ BLOCK DATA DT_ZK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* decay channel information for HADRIN
+ COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
+ & K1Z(16),K2Z(16),WTZ(153),II22,
+ & NZK1(153),NZK2(153),NZK3(153)
+
+* decay channel information for HADRIN
+ CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
+ COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
+
+* Particle masses in GeV *
+ DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
+ & 2*1.7D0, 3*0.D0/
+* Resonance width Gamma in GeV *
+ DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
+* Mean life time in seconds *
+ DATA TAUZ / 16*0.D0 /
+* Charge of particles and resonances *
+ DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
+* Baryonic charge *
+ DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
+* First number of decay channels used for resonances *
+* and decaying particles *
+ DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
+ & 3*460/
+* Last number of decay channels used for resonances *
+* and decaying particles *
+ DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
+ & 3*460/
+* Weight of decay channel *
+ DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
+ & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
+ & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
+ & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
+ & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
+ & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
+ & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
+ & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
+ & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
+ & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
+ & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
+ & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
+ & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
+ & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
+ & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
+ & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
+ & .05D0, .65D0, 9*1.D0 /
+* Particle numbers in decay channel *
+ DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
+ & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
+ & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
+ & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
+ & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
+ & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
+ & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
+ & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
+ DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
+ & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
+ & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
+ & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
+ & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
+ & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
+ & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
+ & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
+ & 1, 8, 1, 8, 1, 9*0 /
+ DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
+ & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
+ & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
+ & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
+ & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
+ & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
+* Particle names *
+ DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
+ & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
+ & 3*'BLANK' /
+* Name of decay channel *
+ DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
+ & 'ANNPI0','APPPI0','ANPPI-'/
+ DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
+ & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
+ & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
+ & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
+ & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
+ & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
+ & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
+ & 'OMOMOM',
+ & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
+ & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
+ & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
+ & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
+ & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
+ & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
+ DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
+ & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
+ & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
+ & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
+ & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
+ & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
+ & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
+ & 9*'BLANK'/
+*= end*block.zk *
+ END
+
+*$ CREATE DT_BLKD43.FOR
+*COPY DT_BLKD43
+*
+*===blkd43=============================================================*
+*
+ BLOCK DATA DT_BLKD43
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+*
+*=== reac =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-dec-91 by Alfredo Ferrari *
+* *
+* This is the original common reac of Hadrin *
+* *
+*----------------------------------------------------------------------*
+*
+
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ DIMENSION
+ & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
+ & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
+ & SPIKP1(315), SPIKPU(278), SPIKPV(372),
+ & SPIKPW(278), SPIKPX(372), SPIKP4(315),
+ & SPIKP5(187), SPIKP6(289),
+ & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
+ & SPIKP9(143), SPIKP0(169), SPKPV(143),
+ & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
+ & SANPEL(84) , SPIKPF(273),
+ & SPKP15(187), SPKP16(272),
+ & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
+ & NURELN(60)
+*
+ DIMENSION NRKLIN(532)
+ EQUIVALENCE (NRK(1,1), NRKLIN(1))
+ EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
+ EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
+ EQUIVALENCE ( UMO(263), UMOK0(1))
+ EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
+ EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
+ EQUIVALENCE ( PLABF(263), PLAK0(1))
+ EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
+ EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
+ EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
+ EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
+ EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
+ EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
+ EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
+ EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
+ EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
+ EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
+ EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
+ EQUIVALENCE ( WK(4913), SPKP16(1))
+ EQUIVALENCE (NRK(1,1), NRKLIN(1))
+ EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
+ EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
+ EQUIVALENCE (NRKLIN( 483), NRKK0(1))
+ EQUIVALENCE (NURE(1,1), NURELN(1))
+*
+**** pi- p data *
+**** pi+ n data *
+ DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
+ & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
+ & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
+ & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
+ & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
+ & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
+ & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
+ & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
+ & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
+ & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
+ DATA PLAKC /
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
+ DATA PLAK0 /
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
+* pp pn np nn *
+ DATA PLAP /
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
+* app apn anp ann *
+ DATA PLAN /
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
+ DATA SIIN / 296*0.D0 /
+ DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
+ & 1.557D0,1.615D0,1.6435D0,
+ & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
+ & 2.286D0,2.366D0,2.482D0,2.56D0,
+ & 2.735D0,2.90D0,
+ & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
+ & 1.496D0,1.527D0,1.557D0,
+ & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
+ & 2.071D0,2.159D0,2.286D0,2.366D0,
+ & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
+ & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
+ & 1.496D0,1.527D0,1.557D0,
+ & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
+ & 2.071D0,2.159D0,2.286D0,2.366D0,
+ & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
+ & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
+ & 1.557D0,1.615D0,1.6435D0,
+ & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
+ & 2.286D0,2.366D0,2.482D0,2.56D0,
+ & 2.735D0, 2.90D0/
+ DATA UMOKC/ 1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0/
+ DATA UMOK0/ 1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0/
+* pp pn np nn *
+ DATA UMOP/
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0/
+* app apn anp ann *
+ DATA UMON /
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0/
+**** reaction channel state particles *
+ DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
+ & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
+ & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
+ & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
+ & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
+ & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
+ & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
+ & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
+ & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
+ & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
+ DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
+ & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
+ & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
+ & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
+ & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
+ & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
+ & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
+ & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
+* *
+* k0 p k0 n ak0 p ak/ n *
+* *
+ DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
+ & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
+ & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
+ & 53, 47, 1, 103, 0, 93, 0/
+* pp pn np nn *
+ DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
+ & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
+ & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
+ & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
+* app apn anp ann *
+ DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
+ & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
+ & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
+ & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
+ & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
+ & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
+ & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
+**** channel cross section *
+ DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
+ & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
+ & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
+ & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
+ & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
+ &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
+ & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
+ & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
+ &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
+ & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
+ & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
+ & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
+ & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
+ & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
+ & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
+ & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
+ & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
+ & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
+ & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
+ & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
+**** pi+ n data *
+ DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
+ & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
+ & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
+ & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
+ & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
+ & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
+ & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
+ & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
+ & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
+ & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
+ & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
+ & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
+ & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
+ & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
+ & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
+ & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
+ & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
+ & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
+ & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
+ & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
+*
+ DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
+ & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
+ & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
+ & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
+ & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
+ & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
+ & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
+ & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
+ & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
+ & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
+ & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
+ & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
+ & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
+ & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
+ & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
+ & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
+ & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
+ & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
+ & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
+**** pi- p data *
+ DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
+ & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
+ & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
+ & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
+ & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
+ & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
+ & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
+ & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
+ & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
+ & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
+ & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
+ & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
+ & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
+ & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
+ & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
+ & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
+ & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
+ & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
+ & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
+*
+ DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
+ & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
+ & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
+ & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
+ & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
+ & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
+ & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
+ & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
+ & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
+ & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
+ & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
+ & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
+ & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
+ & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
+ & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
+ & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
+ & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
+ & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
+ & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
+ & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
+**** pi- n data *
+ DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
+ & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
+ & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
+ & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
+ & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
+ & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
+ & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
+ & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
+ & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
+ & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
+ & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
+ & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
+ & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
+ & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
+ & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
+ & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
+ & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
+ & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
+ & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
+ & 3.3D0, 5.4D0, 7.D0 /
+**** k+ p data *
+ DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
+ & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
+ & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
+ & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
+ & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
+ & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
+ & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
+ & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
+ & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
+ & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
+ & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
+ & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
+**** k+ n data *
+ DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
+ & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
+ & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
+ & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
+ & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
+ & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
+ & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
+ & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
+ & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
+ & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
+ & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
+ & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
+ & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
+ & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
+ & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
+ & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
+ & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
+ & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
+ & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
+**** k- p data *
+ DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
+ & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
+ & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
+ & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
+ & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
+ & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
+ & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
+ & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
+ & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
+ & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
+ & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
+ & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
+ DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
+ & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
+ & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
+ & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
+ & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
+ & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
+ & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
+ & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
+ & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
+ & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
+ & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
+ & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
+ & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
+ & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
+ & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
+ & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
+ & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
+ & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
+ & 10*0.D0/
+***** k- n data *
+ DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
+ & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
+ & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
+ & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
+ & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
+ & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
+ & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
+ & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
+ DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
+ & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
+ & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
+ & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
+ & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
+ & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
+ & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
+ & .39D0, .22D0, .07D0, 0.D0,
+ & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
+ & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
+ & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
+ & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
+ & 5.10D0, 5.44D0, 5.3D0,
+ & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
+***** p p data *
+ DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
+ & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
+ & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
+ & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
+ & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
+ & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
+ & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
+ & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
+ & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
+ & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
+ & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
+***** p n data *
+ DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 1.8D0, .2D0, 12*0.D0,
+ & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
+ & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
+ & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
+ & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
+ & 10*0.D0, .7D0, 5.1D0, 8.D0,
+ & 10*0.D0, .7D0, 5.1D0, 8.D0,
+ & 10*.0D0, .3D0, 2.8D0, 4.7D0,
+ & 10*.0D0, .3D0, 2.8D0, 4.7D0,
+ & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
+ & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
+ & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
+* nn - data *
+* *
+ DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
+ & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
+ & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
+ & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
+ & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
+ & 11.D0, 5.5D0, 3.5D0,
+ & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
+ & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
+ & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
+ & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
+ & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
+ & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
+**************** ap - p - data *
+ DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
+ & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
+ & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
+ & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
+ & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
+ & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
+ & 1.55D0, 1.3D0, .95D0, .75D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
+ & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0/
+ DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
+ & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
+ & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
+ & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
+ & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
+ & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
+ & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
+ & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
+ & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
+ & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
+ & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
+ & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
+ & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
+ & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
+**************** ap - n - data *
+ DATA SAPNEL/
+ & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
+ & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
+ & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
+ & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
+ & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
+ & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0 /
+ DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
+ & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
+ & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
+ & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
+ & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
+ & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
+ & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
+* *
+* *
+**************** an - p - data *
+* *
+ DATA SANPEL/
+ & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
+ & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
+ & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
+ & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
+ & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
+ & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0 /
+ DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
+ & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
+ & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
+ & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
+ & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
+ & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
+ & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
+**** ko - n - data *
+ DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
+ & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
+ & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
+ & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
+ & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
+ & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
+ & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
+ & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
+ & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
+ & 4.85D0, 4.9D0,
+ & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
+ & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
+ & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
+ & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
+ & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
+**** ako - p - data *
+ DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
+ & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
+ & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
+ & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
+ & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
+ & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
+ & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
+ & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
+ & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
+ & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
+ & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
+ & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
+ & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
+ & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
+ & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
+ & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
+ & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
+ & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
+ & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
+ & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
+ DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
+ & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
+*= end*block.blkdt3 *
+ END
+*$ CREATE DT_QEL_POL.FOR
+*COPY DT_QEL_POL
+*
+*===qel_pol============================================================*
+*
+ SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CALL DT_MASS_INI
+ CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+ RETURN
+ END
+
+*$ CREATE DT_GEN_QEL.FOR
+*COPY DT_GEN_QEL
+C==================================================================
+C Generation of a Quasi-Elastic neutrino scattering
+C==================================================================
+*
+*===gen_qel============================================================*
+*
+ SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+C...Generate a quasi-elastic neutrino/antineutrino
+C. Interaction on a nuclear target
+C. INPUT : LTYP = neutrino type (1,...,6)
+C. ENU (GeV) = neutrino energy
+C----------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+**sr - removed (not needed)
+C COMMON /CBAD/ LBAD, NBAD
+C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
+**
+
+ DIMENSION PI(3),PO(3)
+CJR+
+ DATA ININU/0/
+CJR-
+C REAL*8 DBETA(3)
+C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
+ DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
+ DATA AMN /0.93827231D0, 0.93956563D0/
+ DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
+ DATA INIPRI/0/
+
+C DATA PFERMI/0.22D0/
+CGB+...Binding Energy
+ DATA EBIND/0.008D0/
+CGB-...
+
+ ININU=ININU+1
+ IF(ININU.EQ.1)NDSIG=0
+ LBAD = 0
+ enu0=enu
+c write(*,*) enu0
+C...Lepton mass
+ AML = AML0(LTYP) ! massa leptoni
+ AML2 = AML**2 ! massa leptoni **2
+C...Particle labels (LUND)
+ N = 5
+ K(1,1) = 21
+ K(2,1) = 21
+ K(3,1) = 21
+ K(3,3) = 1
+ K(4,1) = 1
+ K(4,3) = 1
+ K(5,1) = 1
+ K(5,3) = 2
+ K0 = (LTYP-1)/2 ! 2
+ K1 = LTYP/2 ! 2
+ KA = 12 + 2*K0 ! 16
+ IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
+ K(1,2) = IS*KA
+ K(4,2) = IS*(KA-1)
+ K(3,2) = IS*24
+ LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
+ IF (LNU .EQ. 2) THEN
+ K(2,2) = 2212
+ K(5,2) = 2112
+ AMI = AMN(1)
+ AMF = AMN(2)
+CJR+
+ PFERMI=PFERMN(2)
+CJR-
+ ELSE
+ K(2,2) = 2112
+ K(5,2) = 2212
+ AMI = AMN(2)
+ AMF = AMN(1)
+CJR+
+ PFERMI=PFERMP(2)
+CJR-
+ ENDIF
+ AMI2 = AMI**2
+ AMF2 = AMF**2
+
+ DO IGB=1,5
+ P(3,IGB) = 0.
+ P(4,IGB) = 0.
+ P(5,IGB) = 0.
+ END DO
+
+ NTRY = 0
+CGB+...
+ EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
+ ENWELL = EFMAX + EBIND ! depth of nuclear potential well
+CGB-...
+
+ 100 CONTINUE
+
+C...4-momentum initial lepton
+ P(1,5) = 0. ! massa
+ P(1,4) = ENU0 ! energia
+ P(1,1) = 0. ! px
+ P(1,2) = 0. ! py
+ P(1,3) = ENU0 ! pz
+
+C PF = PFERMI*PYR(0)**(1./3.)
+c write(23,*) PYR(0)
+c write(*,*) 'Pfermi=',PF
+c PF = 0.
+ NTRY=NTRY+1
+C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
+ IF (NTRY .GT. 500) THEN
+ LBAD = 1
+ WRITE (LOUT,1001) NBAD, ENU
+ RETURN
+ ENDIF
+C CT = -1. + 2.*PYR(0)
+c CT = -1.
+C ST = SQRT(1.-CT*CT)
+C F = 2.*3.1415926*PYR(0)
+c F = 0.
+
+C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
+C P(2,1) = PF*ST*COS(F) ! px
+C P(2,2) = PF*ST*SIN(F) ! py
+C P(2,3) = PF*CT ! pz
+C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
+ P(2,1) = P21
+ P(2,2) = P22
+ P(2,3) = P23
+ P(2,4) = P24
+ P(2,5) = P25
+ beta1=-p(2,1)/p(2,4)
+ beta2=-p(2,2)/p(2,4)
+ beta3=-p(2,3)/p(2,4)
+ N=2
+C WRITE(6,*)' before transforming into target rest frame'
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
+
+C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
+ N=5
+
+ phi11=atan(p(1,2)/p(1,3))
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+
+ CALL DT_TESTROT(PI,Po,PHI11,1)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+c WRITE(*,*) po
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+ phi12=atan(p(1,1)/p(1,3))
+
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,2)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+c WRITE(*,*) po
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+
+ enu=p(1,4)
+
+C...Kinematical limits in Q**2
+c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
+ S = P(2,5)**2 + 2.*ENU*P(2,5)
+ SQS = SQRT(S) ! E centro massa
+ IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
+ ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
+ PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
+ PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
+ Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
+ Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
+ IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
+
+C...Generate Q**2
+ DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
+ 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
+ DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
+ IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
+ CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
+ NDSIG=NDSIG+1
+C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
+C &Q2,Q2min,Q2MAX,DSIGEV
+
+C...c.m. frame. Neutrino along z axis
+ DETOT = (P(1,4)) + (P(2,4)) ! e totale
+ DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
+ DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
+ DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
+c WRITE(*,*)
+c WRITE(*,*)
+C WRITE(*,*) 'Input values laboratory frame'
+ N=2
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
+
+ N=5
+c STHETA = ULANGL(P(1,3),P(1,1))
+c write(*,*) 'stheta' ,stheta
+c stheta=0.
+c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
+c WRITE(*,*)
+c WRITE(*,*)
+C WRITE(*,*) 'Output values cm frame'
+C...Kinematic in c.m. frame
+ CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
+ STSTAR = SQRT(1.-CTSTAR**2)
+ PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
+ P(4,5) = AML ! massa leptone
+ P(4,4) = ELF ! e leptone
+ P(4,3) = PLF*CTSTAR ! px
+ P(4,1) = PLF*STSTAR*COS(PHI) ! py
+ P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
+
+ P(5,5) = AMF ! barione
+ P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
+ P(5,3) = -P(4,3) ! px
+ P(5,1) = -P(4,1) ! py
+ P(5,2) = -P(4,2) ! pz
+
+ P(3,5) = -Q2
+ P(3,1) = P(1,1)-P(4,1)
+ P(3,2) = P(1,2)-P(4,2)
+ P(3,3) = P(1,3)-P(4,3)
+ P(3,4) = P(1,4)-P(4,4)
+
+C...Transform back to laboratory frame
+C WRITE(*,*) 'before going back to nucl rest frame'
+c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
+ N=5
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
+
+C WRITE(*,*) 'Now back in nucl rest frame'
+ IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
+
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,3)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI11,4)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+
+c********************************************
+
+C WRITE(*,*) 'Now back in lab frame'
+
+ CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
+
+CGB+...
+C...test (on final momentum of nucleon) if Fermi-blocking
+C...is operating
+ ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
+ & - P(5,5)
+ IF (ENUCL.LT. EFMAX) THEN
+ IF(INIPRI.LT.10)THEN
+ INIPRI=INIPRI+1
+C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
+C...the interaction is not possible due to Pauli-Blocking and
+C...it must be resampled
+ ENDIF
+ GOTO 100
+ ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
+ IF(INIPRI.LT.10)THEN
+ INIPRI=INIPRI+1
+C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
+ ENDIF
+C Reject (J:R) here all these events
+C are otherwise rejected in dpmjet
+ GOTO 100
+C...the interaction is possible, but the nucleon remains inside
+C...the nucleus. The nucleus is therefore left excited.
+C...We treat this case as a nucleon with 0 kinetic energy.
+C P(5,5) = AMF
+C P(5,4) = AMF
+C P(5,1) = 0.
+C P(5,2) = 0.
+C P(5,3) = 0.
+ ELSE IF (ENUCL.GE.ENWELL) THEN
+C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
+C...the interaction is possible, the nucleon can exit the nucleus
+C...but the nuclear well depth must be subtracted. The nucleus could be
+C...left in an excited state.
+ Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
+C P(5,4) = ENUCL-ENWELL + AMF
+ Pnucl = SQRT(P(5,4)**2-AMF**2)
+C...The 3-momentum is scaled assuming that the direction remains
+C...unaffected
+ P(5,1) = P(5,1) * Pnucl/Pstart
+ P(5,2) = P(5,2) * Pnucl/Pstart
+ P(5,3) = P(5,3) * Pnucl/Pstart
+C WRITE(6,*)' qel new P(5,4) ',P(5,4)
+ ENDIF
+CGB-...
+ DSIGSU=DSIGSU+DSIGEV
+
+ GA=P(4,4)/P(4,5)
+ BGX=P(4,1)/P(4,5)
+ BGY=P(4,2)/P(4,5)
+ BGZ=P(4,3)/P(4,5)
+*
+ DBETB(1)=BGX/GA
+ DBETB(2)=BGY/GA
+ DBETB(3)=BGZ/GA
+ IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
+
+ CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
+
+ ENDIF
+c
+C PRINT*,' FINE EVENTO '
+ enu=enu0
+ RETURN
+
+ 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
+ END
+
+*$ CREATE DT_MASS_INI.FOR
+*COPY DT_MASS_INI
+C====================================================================
+C. Masses
+C====================================================================
+*
+*===mass_ini===========================================================*
+*
+ SUBROUTINE DT_MASS_INI
+C...Initialize the kinematics for the quasi-elastic cross section
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+
+ EML(1) = 0.51100D-03 ! e-
+ EML(2) = EML(1) ! e+
+ EML(3) = 0.105659D0 ! mu-
+ EML(4) = EML(3) ! mu+
+ EML(5) = 1.7777D0 ! tau-
+ EML(6) = EML(5) ! tau+
+ EMPROT = 0.93827231D0 ! p
+ EMNEUT = 0.93956563D0 ! n
+ EMPROTSQ = EMPROT**2
+ EMNEUTSQ = EMNEUT**2
+ EMN = (EMPROT + EMNEUT)/2.
+ EMNSQ = EMN**2
+ DO J=1,3
+ J0 = 2*(J-1)
+ EMN1(J0+1) = EMNEUT
+ EMN1(J0+2) = EMPROT
+ EMN2(J0+1) = EMPROT
+ EMN2(J0+2) = EMNEUT
+ ENDDO
+ DO J=1,6
+ EMLSQ(J) = EML(J)**2
+ ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
+ ENDDO
+ RETURN
+ END
+
+*$ CREATE DT_DSQEL_Q2.FOR
+*COPY DT_DSQEL_Q2
+*
+*===dsqel_q2===========================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
+
+C...differential cross section for Quasi-Elastic scattering
+C. nu + N -> l + N'
+C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
+C.
+C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
+C. ENU (GeV) = Neutrino energy
+C. Q2 (GeV**2) = (Transfer momentum)**2
+C.
+C. OUTPUT : DSQEL_Q2 = differential cross section :
+C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
+C------------------------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+**sr - removed (not needed)
+C COMMON /CAXIAL/ FA0, AXIAL2
+**
+
+ DIMENSION SS(6)
+ DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
+ DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
+ DATA AXIAL2 /1.03D0/ ! to be checked
+
+ FA0=-1.253D0
+ CSI = 3.71D0 ! ???
+ GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
+ GVM = (1.D0+CSI)*GVE ! G_m (q**2)
+ X = Q2/(EMN*EMN) ! emn=massa barione
+ XA = X/4.D0
+ FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
+ FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
+ FA = FA0/(1.D0 + Q2/AXIAL2)**2
+ FFA = FA*FA
+ FFV1 = FV1*FV1
+ FFV2 = FV2*FV2
+ RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
+ A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
+ A2 = -RM * ((FV1 + FV2)**2 + FFA)
+ AA = (XA+0.25D0*RM)*(A1 + A2)
+ BB = -X*FA*(FV1 + FV2)
+ CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
+ SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
+ DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
+ IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
+
+ RETURN
+ END
+
+*$ CREATE DT_PREPOLA.FOR
+*COPY DT_PREPOLA
+*
+*===prepola============================================================*
+*
+ SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+c
+c By G. Battistoni and E. Scapparone (sept. 1997)
+c According to:
+c Albright & Jarlskog, Nucl Phys B84 (1975) 467
+c
+c
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+ COMMON /QNPOL/ POLARX(4),PMODUL
+
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+**sr - removed (not needed)
+C COMMON /CAXIAL/ FA0, AXIAL2
+C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
+C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
+**
+ REAL*8 POL(4,4),BB2(3)
+ DIMENSION SS(6)
+C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
+ DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
+**sr uncommented since common block CAXIAL is now commented
+ DATA AXIAL2 /1.03D0/ ! to be checked
+**
+
+ RML=P(4,5)
+ RMM=0.93960D+00
+ FM2 = RMM**2
+ MPI = 0.135D+00
+ OLDQ2=Q2
+ FA0=-1.253D+00
+ CSI = 3.71D+00 !
+ GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
+ GVM = (1.D0+CSI)*GVE ! G_m (q**2)
+ X = Q2/(EMN*EMN) ! emn=massa barione
+ XA = X/4.D0
+ FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
+ FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
+ FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
+ FFA = FA*FA
+ FFV1 = FV1*FV1
+ FFV2 = FV2*FV2
+ FP=2.D0*FA*RMM/(MPI**2 + Q2)
+ RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
+ A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
+ A2 = -RM * ((FV1 + FV2)**2 + FFA)
+ AA = (XA+0.25D+00*RM)*(A1 + A2)
+ BB = -X*FA*(FV1 + FV2)
+ CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
+ SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
+
+ OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
+ OMEGA2=4.D+00*CC
+ OMEGA3=2.D+00*FA*(FV1+FV2)
+ OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
+ 1 (Q2/FM2))*FP**2)
+ OMEGA5=OMEGA2
+ OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
+ WW1=2.D+00*OMEGA1*EMN**2
+ WW2=2.D+00*OMEGA2*EMN**2
+ WW3=2.D+00*OMEGA3*EMN**2
+ WW4=2.D+00*OMEGA4*EMN**2
+ WW5=2.D+00*OMEGA5*EMN**2
+
+ DO I=1,3
+ BB2(I)=-P(4,I)/P(4,4)
+ END DO
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
+ N=5
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
+
+* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'Prepola: now in lepton rest frame'
+ EE=ENU
+ QM2=Q2+RML**2
+ U=Q2/(2.*RMM)
+ FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
+ + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
+ + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
+
+ FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
+ + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
+
+ FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
+
+ DO I=1,3
+ POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
+ POLARX(I)=POL(4,I)
+ END DO
+
+ PMODUL=0.D0
+ DO I=1,3
+ PMODUL=PMODUL+POL(4,I)**2
+ END DO
+
+ IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
+ IF(NEUDEC.EQ.1) THEN
+ CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
+ + ETL,PXL,PYL,PZL,
+ + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+c
+c Tau has decayed in muon
+c
+ ENDIF
+ IF(NEUDEC.EQ.2) THEN
+ CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
+ + ETL,PXL,PYL,PZL,
+ + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+c
+c Tau has decayed in electron
+c
+ ENDIF
+ K(4,1)=15
+ K(4,4) = 6
+ K(4,5) = 8
+ N=N+3
+c
+c fill common for muon(electron)
+c
+ P(6,1)=PXL
+ P(6,2)=PYL
+ P(6,3)=PZL
+ P(6,4)=ETL
+ K(6,1)=1
+ IF(JTYP.EQ.5) THEN
+ IF(NEUDEC.EQ.1) THEN
+ P(6,5)=EML(JTYP-2)
+ K(6,2)=13
+ ELSEIF(NEUDEC.EQ.2) THEN
+ P(6,5)=EML(JTYP-4)
+ K(6,2)=11
+ ENDIF
+ ELSEIF(JTYP.EQ.6) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(6,2)=-13
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(6,2)=-11
+ ENDIF
+ END IF
+ K(6,3)=4
+ K(6,4)=0
+ K(6,5)=0
+c
+c fill common for tau_(anti)neutrino
+c
+ P(7,1)=PXB
+ P(7,2)=PYB
+ P(7,3)=PZB
+ P(7,4)=ETB
+ P(7,5)=0.
+ K(7,1)=1
+ IF(JTYP.EQ.5) THEN
+ K(7,2)=16
+ ELSEIF(JTYP.EQ.6) THEN
+ K(7,2)=-16
+ END IF
+ K(7,3)=4
+ K(7,4)=0
+ K(7,5)=0
+c
+c Fill common for muon(electron)_(anti)neutrino
+c
+ P(8,1)=PXN
+ P(8,2)=PYN
+ P(8,3)=PZN
+ P(8,4)=ETN
+ P(8,5)=0.
+ K(8,1)=1
+ IF(JTYP.EQ.5) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(8,2)=-14
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(8,2)=-12
+ ENDIF
+ ELSEIF(JTYP.EQ.6) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(8,2)=14
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(8,2)=12
+ ENDIF
+ END IF
+ K(8,3)=4
+ K(8,4)=0
+ K(8,5)=0
+ ENDIF
+c WRITE(*,*)
+c WRITE(*,*)
+
+c IF(PMODUL.GE.1.D+00) THEN
+c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
+c write(*,*) pmodul
+c DO I=1,3
+c POL(4,I)=POL(4,I)/PMODUL
+c POLARX(I)=POL(4,I)
+c END DO
+c PMODUL=0.
+c DO I=1,3
+c PMODUL=PMODUL+POL(4,I)**2
+c END DO
+c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
+c
+c ENDIF
+
+c WRITE(*,*) 'PMODUL = ',PMODUL
+
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'prepola: Now back to nucl rest frame'
+
+ CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
+
+ XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
+ YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
+ ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
+ DO NDC =6,8
+ V(NDC,1) = XDC
+ V(NDC,2) = YDC
+ V(NDC,3) = ZDC
+ END DO
+
+ RETURN
+ END
+
+*$ CREATE DT_TESTROT.FOR
+*COPY DT_TESTROT
+*
+*===testrot============================================================*
+*
+ SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ROT(3,3),PI(3),PO(3)
+
+ IF (MODE.EQ.1) THEN
+ ROT(1,1) = 1.D0
+ ROT(1,2) = 0.D0
+ ROT(1,3) = 0.D0
+ ROT(2,1) = 0.D0
+ ROT(2,2) = COS(PHI)
+ ROT(2,3) = -SIN(PHI)
+ ROT(3,1) = 0.D0
+ ROT(3,2) = SIN(PHI)
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.2) THEN
+ ROT(1,1) = 0.D0
+ ROT(1,2) = 1.D0
+ ROT(1,3) = 0.D0
+ ROT(2,1) = COS(PHI)
+ ROT(2,2) = 0.D0
+ ROT(2,3) = -SIN(PHI)
+ ROT(3,1) = SIN(PHI)
+ ROT(3,2) = 0.D0
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.3) THEN
+ ROT(1,1) = 0.D0
+ ROT(2,1) = 1.D0
+ ROT(3,1) = 0.D0
+ ROT(1,2) = COS(PHI)
+ ROT(2,2) = 0.D0
+ ROT(3,2) = -SIN(PHI)
+ ROT(1,3) = SIN(PHI)
+ ROT(2,3) = 0.D0
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.4) THEN
+ ROT(1,1) = 1.D0
+ ROT(2,1) = 0.D0
+ ROT(3,1) = 0.D0
+ ROT(1,2) = 0.D0
+ ROT(2,2) = COS(PHI)
+ ROT(3,2) = -SIN(PHI)
+ ROT(1,3) = 0.D0
+ ROT(2,3) = SIN(PHI)
+ ROT(3,3) = COS(PHI)
+ ELSE
+ STOP ' TESTROT: mode not supported!'
+ ENDIF
+ DO 1 J=1,3
+ PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
+ 1 CONTINUE
+
+ RETURN
+ END
+
+*$ CREATE DT_LEPDCYP.FOR
+*COPY DT_LEPDCYP
+*
+*===lepdcyp============================================================*
+*
+ SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
+ & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+C
+C-----------------------------------------------------------------
+C
+C Author :- G. Battistoni 10-NOV-1995
+C
+C=================================================================
+C
+C Purpose : performs decay of polarized lepton in
+C its rest frame: a => b + l + anti-nu
+C (Example: mu- => nu-mu + e- + anti-nu-e)
+C Polarization is assumed along Z-axis
+C WARNING:
+C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
+C OF NEGLIGIBLE MASS
+C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
+C IN THIS VERSION
+C
+C Method : modifies phase space distribution obtained
+C by routine EXPLOD using a rejection against the
+C matrix element for unpolarized lepton decay
+C
+C Inputs : Mass of a : AMA
+C Mass of l : AML
+C Polar. of a: POL
+C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
+C POL = -1)
+C
+C Outputs : kinematic variables in the rest frame of decaying lepton
+C ETL,PXL,PYL,PZL 4-moment of l
+C ETB,PXB,PYB,PZB 4-moment of b
+C ETN,PXN,PYN,PZN 4-moment of anti-nu
+C
+C============================================================
+C +
+C Declarations.
+C -
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER ( KALGNM = 2 )
+ PARAMETER ( ANGLGB = 5.0D-16 )
+ PARAMETER ( ANGLSQ = 2.5D-31 )
+ PARAMETER ( AXCSSV = 0.2D+16 )
+ PARAMETER ( ANDRFL = 1.0D-38 )
+ PARAMETER ( AVRFLW = 1.0D+38 )
+ PARAMETER ( AINFNT = 1.0D+30 )
+ PARAMETER ( AZRZRZ = 1.0D-30 )
+ PARAMETER ( EINFNT = +69.07755278982137 D+00 )
+ PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
+ PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( CSNNRM = 2.0D-15 )
+ PARAMETER ( DMXTRN = 1.0D+08 )
+ PARAMETER ( ZERZER = 0.D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( THRTHR = 3.D+00 )
+ PARAMETER ( FOUFOU = 4.D+00 )
+ PARAMETER ( FIVFIV = 5.D+00 )
+ PARAMETER ( SIXSIX = 6.D+00 )
+ PARAMETER ( SEVSEV = 7.D+00 )
+ PARAMETER ( EIGEIG = 8.D+00 )
+ PARAMETER ( ANINEN = 9.D+00 )
+ PARAMETER ( TENTEN = 10.D+00 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( ONETHI = ONEONE / THRTHR )
+ PARAMETER ( TWOTHI = TWOTWO / THRTHR )
+ PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
+ PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
+ PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
+ PARAMETER ( CLIGHT = 2.99792458 D+10 )
+ PARAMETER ( AVOGAD = 6.0221367 D+23 )
+ PARAMETER ( AMELGR = 9.1093897 D-28 )
+ PARAMETER ( PLCKBR = 1.05457266 D-27 )
+ PARAMETER ( ELCCGS = 4.8032068 D-10 )
+ PARAMETER ( ELCMKS = 1.60217733 D-19 )
+ PARAMETER ( AMUGRM = 1.6605402 D-24 )
+ PARAMETER ( AMMUMU = 0.113428913 D+00 )
+ PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
+ PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
+ PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
+ PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
+ PARAMETER ( PLABRC = 0.197327053 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMMUON = 0.105658389 D+00 )
+ PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
+ PARAMETER ( GEVMEV = 1.0 D+03 )
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
+ PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
+ PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
+C +
+C variables for EXPLOD
+C -
+ PARAMETER ( KPMX = 10 )
+ DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
+ & PZEXPL (KPMX), ETEXPL (KPMX)
+C +
+C test variables
+C -
+**sr - removed (not needed)
+C COMMON /GBATNU/ ELERAT,NTRY
+**
+C +
+C Initializes test variables
+C -
+ NTRY = 0
+ ELERAT = 0.D+00
+C +
+C Maximum value for matrix element
+C -
+ ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
+ & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
+C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+C Inputs for EXPLOD
+C part. no. 1 is l (e- in mu- decay)
+C part. no. 2 is b (nu-mu in mu- decay)
+C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ NPEXPL = 3
+ ETOTEX = AMA
+ AMEXPL(1) = AML
+ AMEXPL(2) = 0.D+00
+ AMEXPL(3) = 0.D+00
+C +
+C phase space distribution
+C -
+ 100 CONTINUE
+ NTRY = NTRY + 1
+
+ CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
+ & PYEXPL, PZEXPL )
+
+C +
+C Calculates matrix element:
+C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
+C Here CTH is the cosine of the angle between anti-nu and Z axis
+C -
+ CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
+ & PZEXPL(3)**2 )
+ PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
+ PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
+ & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
+ ELEMAT = 16.D+00 * PROD1 * PROD2
+ IF(ELEMAT.GT.ELEMAX) THEN
+ WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
+ STOP
+ ENDIF
+C +
+C Here performs the rejection
+C -
+ TEST = DT_RNDM(ETOTEX) * ELEMAX
+ IF ( TEST .GT. ELEMAT ) GO TO 100
+C +
+C final assignment of variables
+C -
+ ELERAT = ELEMAT/ELEMAX
+ ETL = ETEXPL(1)
+ PXL = PXEXPL(1)
+ PYL = PYEXPL(1)
+ PZL = PZEXPL(1)
+ ETB = ETEXPL(2)
+ PXB = PXEXPL(2)
+ PYB = PYEXPL(2)
+ PZB = PZEXPL(2)
+ ETN = ETEXPL(3)
+ PXN = PXEXPL(3)
+ PYN = PYEXPL(3)
+ PZN = PZEXPL(3)
+ 999 RETURN
+ END
+
+*$ CREATE DT_GEN_DELTA.FOR
+*COPY DT_GEN_DELTA
+C==================================================================
+C. Generation of Delta resonance events
+C==================================================================
+*
+*===gen_delta==========================================================*
+*
+ SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C...Generate a Delta-production neutrino/antineutrino
+C. CC-interaction on a nucleon
+C
+C. INPUT ENU (GeV) = Neutrino Energy
+C. LLEP = neutrino type
+C. LTARG = nucleon target type 1=p, 2=n.
+C. JINT = 1:CC, 2::NC
+C.
+C. OUTPUT PPL(4) 4-monentum of final lepton
+C----------------------------------------------------
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+**sr - removed (not needed)
+C COMMON /CBAD/ LBAD, NBAD
+**
+
+ DIMENSION PI(3),PO(3)
+C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
+ DIMENSION AML0(6),AMN(2)
+ DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
+ DATA AMN /0.93827231, 0.93956563/
+ DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
+
+c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
+ LBAD = 0
+C...Final lepton mass
+ IF (JINT.EQ.1) THEN
+ AML = AML0(LLEP)
+ ELSE
+ AML = 0.
+ ENDIF
+ AML2 = AML**2
+
+C...Particle labels (LUND)
+ N = 5
+ K(1,1) = 21
+ K(2,1) = 21
+ K(3,1) = 21
+ K(4,1) = 1
+ K(3,3) = 1
+ K(4,3) = 1
+ IF (LTARG .EQ. 1) THEN
+ K(2,2) = 2212
+ ELSE
+ K(2,2) = 2112
+ ENDIF
+ K0 = (LLEP-1)/2
+ K1 = LLEP/2
+ KA = 12 + 2*K0
+ IS = -1 + 2*LLEP - 4*K1
+ LNU = 2 - LLEP + 2*K1
+ K(1,2) = IS*KA
+ K(5,1) = 1
+ K(5,3) = 2
+ IF (JINT .EQ. 1) THEN ! CC interactions
+ K(3,2) = IS*24
+ K(4,2) = IS*(KA-1)
+ IF(LNU.EQ.1) THEN
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2224
+ ELSE
+ K(5,2) = 2214
+ ENDIF
+ ELSE
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2114
+ ELSE
+ K(5,2) = 1114
+ ENDIF
+ ENDIF
+ ELSE
+ K(3,2) = 23 ! NC (Z0) interactions
+ K(4,2) = K(1,2)
+**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
+* Delta0 for neutron (LTARG=2)
+C IF (LTARG .EQ. 1) THEN
+C K(5,2) = 2114
+C ELSE
+C K(5,2) = 2214
+C ENDIF
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2214
+ ELSE
+ K(5,2) = 2114
+ ENDIF
+**
+ ENDIF
+
+C...4-momentum initial lepton
+ P(1,5) = 0.
+ P(1,4) = ENU
+ P(1,1) = 0.
+ P(1,2) = 0.
+ P(1,3) = ENU
+C...4-momentum initial nucleon
+ P(2,5) = AMN(LTARG)
+C P(2,4) = P(2,5)
+C P(2,1) = 0.
+C P(2,2) = 0.
+C P(2,3) = 0.
+ P(2,1) = P21
+ P(2,2) = P22
+ P(2,3) = P23
+ P(2,4) = P24
+ P(2,5) = P25
+ N=2
+ beta1=-p(2,1)/p(2,4)
+ beta2=-p(2,2)/p(2,4)
+ beta3=-p(2,3)/p(2,4)
+ N=2
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
+
+C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
+
+ phi11=atan(p(1,2)/p(1,3))
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+
+ CALL DT_TESTROT(PI,Po,PHI11,1)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+ phi12=atan(p(1,1)/p(1,3))
+
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,2)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+
+ ENUU=P(1,4)
+
+C...Generate the Mass of the Delta
+ NTRY = 0
+100 R = PYR(0)
+ AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
+ NTRY = NTRY + 1
+ IF (NTRY .GT. 1000) THEN
+ LBAD = 1
+ WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
+ RETURN
+ ENDIF
+ IF (AMD .LT. AMDMIN) GOTO 100
+ ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
+ IF (ENUU .LT. ET) GOTO 100
+
+C...Kinematical limits in Q**2
+ S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
+ SQS = SQRT(S)
+ PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
+ ELF = (S - AMD**2 + AML2)/(2.*SQS)
+ PLF = SQRT(ELF**2 - AML2)
+ Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
+ Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
+ IF (Q2MIN .LT. 0.) Q2MIN = 0.
+
+ DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
+200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
+ DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
+ IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
+
+C...Generate the kinematics of the final particles
+ EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
+ GAM = EISTAR/AMN(LTARG)
+ BET = PSTAR/EISTAR
+ CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
+ EL = GAM*(ELF + BET*PLF*CTSTAR)
+ PLZ = GAM*(PLF*CTSTAR + BET*ELF)
+ PL = SQRT(EL**2 - AML2)
+ PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
+ PHI = 6.28319*PYR(0)
+ P(4,1) = PLT*COS(PHI)
+ P(4,2) = PLT*SIN(PHI)
+ P(4,3) = PLZ
+ P(4,4) = EL
+ P(4,5) = AML
+
+C...4-momentum of Delta
+ P(5,1) = -P(4,1)
+ P(5,2) = -P(4,2)
+ P(5,3) = ENUU-P(4,3)
+ P(5,4) = ENUU+AMN(LTARG)-P(4,4)
+ P(5,5) = AMD
+
+C...4-momentum of intermediate boson
+ P(3,5) = -Q2
+ P(3,4) = P(1,4)-P(4,4)
+ P(3,1) = P(1,1)-P(4,1)
+ P(3,2) = P(1,2)-P(4,2)
+ P(3,3) = P(1,3)-P(4,3)
+ N=5
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,3)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI11,4)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+c********************************************
+C transform back into Lab.
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
+
+C WRITE(6,*)' Lab fram ( fermi incl.) '
+ N=5
+ CALL PYEXEC
+
+ RETURN
+1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
+ END
+
+*$ CREATE DT_DSIGMA_DELTA.FOR
+*COPY DT_DSIGMA_DELTA
+*
+*===dsigma_delta=======================================================*
+*
+ DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C...Reaction nu + N -> lepton + Delta
+C. returns the cross section
+C. dsigma/dt
+C. INPUT LNU = 1, 2 (neutrino-antineutrino)
+C. QQ = t (always negative) GeV**2
+C. S = (c.m energy)**2 GeV**2
+C. OUTPUT = 10**-38 cm+2/GeV**2
+C-----------------------------------------------------
+ REAL*8 MN, MN2, MN4, MD,MD2, MD4
+ DATA MN /0.938/
+ DATA PI /3.1415926/
+
+ GF = (1.1664 * 1.97)
+ GF2 = GF*GF
+ MN2 = MN*MN
+ MN4 = MN2*MN2
+ MD2 = MD*MD
+ MD4 = MD2*MD2
+ AML2 = AML*AML
+ AML4 = AML2*AML2
+ VQ = (MN2 - MD2 - QQ)/2.
+ VPI = (MN2 + MD2 - QQ)/2.
+ VK = (S + QQ - MN2 - AML2)/2.
+ PIK = (S - MN2)/2.
+ QK = (AML2 - QQ)/2.
+ PIQ = (QQ + MN2 - MD2)/2.
+ Q = SQRT(-QQ)
+ C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
+ C3 = SQRT(3.)*C3V/MN
+ C4 = -C3/MD ! attenzione al segno
+ C5A = 1.18/(1.-QQ/0.4225)**2
+ C32 = C3**2
+ C42 = C4**2
+ C5A2 = C5A**2
+
+ IF (LNU .EQ. 1) THEN
+ ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
+ . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
+ . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
+ . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
+ ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
+ . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
+ . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
+ . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
+ . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
+ . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
+ . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
+ . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
+ . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
+ . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
+ . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
+ . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
+ . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
+ . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
+ . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
+ . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
+ . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
+ . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
+ . *C42-2.*MD2*VPI*QK**2*C32+ANS3
+ ELSE
+ ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
+ . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
+ . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
+ . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
+ ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
+ . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
+ . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
+ . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
+ . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
+ . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
+ . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
+ . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
+ . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
+ . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
+ . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
+ . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
+ . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
+ . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
+ . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
+ . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
+ . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
+ . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
+ . *C42-2.*MD2*VPI*QK**2*C32+ANS3
+ ENDIF
+ ANS1=32.*ANS2
+ ANS=ANS1/(3.*MD2)
+ P1CM = (S-MN2)/(2.*SQRT(S))
+ DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
+
+ RETURN
+ END
+
+*$ CREATE DT_QGAUS.FOR
+*COPY DT_QGAUS
+*
+*===qgaus==============================================================*
+*
+ SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION X(5),W(5)
+ DATA X/.1488743389D0,.4333953941D0,
+ & .6794095682D0,.8650633666D0,.9739065285D0
+ */
+ DATA W/.2955242247D0,.2692667193D0,
+ & .2190863625D0,.1494513491D0,.0666713443D0
+ */
+ XM=0.5D0*(B+A)
+ XR=0.5D0*(B-A)
+ SS=0
+ DO 11 J=1,5
+ DX=XR*X(J)
+ SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
+ & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
+11 CONTINUE
+ SS=XR*SS
+
+ RETURN
+ END
+*$ CREATE DT_DIQBRK.FOR
+*COPY DT_DIQBRK
+*
+*===diqbrk=============================================================*
+*
+ SUBROUTINE DT_DIQBRK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+C IF(DT_RNDM(VV).LE.0.5D0)THEN
+C CALL GSQBS1(NHKK)
+C CALL GSQBS2(NHKK)
+C CALL USQBS1(NHKK)
+C CALL USQBS2(NHKK)
+C CALL GSABS1(NHKK)
+C CALL GSABS2(NHKK)
+C CALL USABS1(NHKK)
+C CALL USABS2(NHKK)
+C ELSE
+C CALL GSQBS2(NHKK)
+C CALL GSQBS1(NHKK)
+C CALL USQBS2(NHKK)
+C CALL USQBS1(NHKK)
+C CALL GSABS2(NHKK)
+C CALL GSABS1(NHKK)
+C CALL USABS2(NHKK)
+C CALL USABS1(NHKK)
+C ENDIF
+
+ IF(DT_RNDM(VV).LE.0.5D0) THEN
+ CALL DT_DBREAK(1)
+ CALL DT_DBREAK(2)
+ CALL DT_DBREAK(3)
+ CALL DT_DBREAK(4)
+ CALL DT_DBREAK(5)
+ CALL DT_DBREAK(6)
+ CALL DT_DBREAK(7)
+ CALL DT_DBREAK(8)
+ ELSE
+ CALL DT_DBREAK(2)
+ CALL DT_DBREAK(1)
+ CALL DT_DBREAK(4)
+ CALL DT_DBREAK(3)
+ CALL DT_DBREAK(6)
+ CALL DT_DBREAK(5)
+ CALL DT_DBREAK(8)
+ CALL DT_DBREAK(7)
+ ENDIF
+
+ RETURN
+ END
+
+*$ CREATE MUSQBS2.FOR
+*COPY MUSQBS2
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
+C
+C USQBS-2 diagram (split target diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+ COMMON /EVFLAG/ NUMEV
+C
+C USQBS-2 diagram (split target diquark)
+C
+C
+C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
+C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
+C
+C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ IREJ=0
+ IF(IPIP.EQ.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
+C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1T diquark
+ XDIQT=PHKK(4,NC1T)*2.D0/UMO
+ XVQP=PHKK(4,NC1P)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
+ * UMO, XDIQT,XVQP
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQT/2.0D0
+ XAQMAX = 2.D0*XVQP/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQP/3.0D0
+ XAQMAX = XDIQT/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
+ & XDIQT,XVQP,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1T diquark and NC1P quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQT=XDIQT-XSQ
+ XVQP =XVQP -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQT=XDIQT-XSAQ
+ XVQP =XVQP -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
+C
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQT)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQII=XDIQT-XVTQI
+ ELSE
+ XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQI=XDIQT-XVTQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP1,IPP2)
+C
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ IDHKT(1) =IPP1
+ ISTHKT(1) =951
+ JMOHKT(1,1)=NC2P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+ PHKT(1,1) =PHKK(1,NC2P)
+ PHKT(2,1) =PHKK(2,NC2P)
+ PHKT(3,1) =PHKK(3,NC2P)
+ PHKT(4,1) =PHKK(4,NC2P)
+C PHKT(5,1) =PHKK(5,NC2P)
+ XMIST =(PHKT(4,1)**2-
+ * PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC2P)
+ VHKT(2,1) =VHKK(2,NC2P)
+ VHKT(3,1) =VHKK(3,NC2P)
+ VHKT(4,1) =VHKK(4,NC2P)
+ WHKT(1,1) =WHKK(1,NC2P)
+ WHKT(2,1) =WHKK(2,NC2P)
+ WHKT(3,1) =WHKK(3,NC2P)
+ WHKT(4,1) =WHKK(4,NC2P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+ IDHKT(2+IIGLU1) =IP21
+ ISTHKT(2+IIGLU1) =952
+ JMOHKT(1,2+IIGLU1)=NC1T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
+C PHKT(5,2) =PHKK(5,NC1T)
+ XMIST =(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =95
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ XMIST
+ * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+C * JDAHKT(1,1),
+C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+C & JMOHKT(1,IIG),JMOHKT(2,IIG),
+C * JDAHKT(1,IIG),
+C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(4+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(4+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(4+IIGLU1) =951
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
+ PHKT(5,4+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IDHKT(5+IIGLU1) =IP22
+ ISTHKT(5+IIGLU1) =952
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XMIST =(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =95
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ XMIST
+ * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+C IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+C ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 6',
+C * CHAMAL,PHKT(5,6+IIGLU1)
+ GO TO 3466
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(7) =1000*IPP1+100*ISQ+1
+ IDHKT(7+IIGLU1) =IP1
+ ISTHKT(7+IIGLU1) =951
+ JMOHKT(1,7+IIGLU1)=NC1P
+ JMOHKT(2,7+IIGLU1)=0
+**NEW
+C JDAHKT(1,7+IIGLU1)=9+IIGLU1
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+**
+ JDAHKT(2,7+IIGLU1)=0
+ PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
+C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
+ PHKT(5,7+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
+ ENDIF
+ ISTHKT(8+IIGLU1+IIGLU2) =952
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
+ * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
+ * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
+ * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
+ * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
+C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
+ IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
+C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,8) =PHKK(5,NC2T)
+ XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =95
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+**NEW
+C PHKT(1,9+IIGLU1+IIGLU2)
+C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+C PHKT(2,9+IIGLU1+IIGLU2)
+C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+C PHKT(3,9+IIGLU1+IIGLU2)
+C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+C PHKT(4,9+IIGLU1+IIGLU2)
+C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+**
+ XMIST
+ * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
+C * JDAHKT(1,IIG),
+C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+C 91 CONTINUE
+C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
+C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
+C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 9',
+C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+
+*$ CREATE MGSQBS2.FOR
+*COPY MGSQBS2
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
+C
+C GSQBS-2 diagram (split target diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+C
+C GSQBS-2 diagram (split target diquark)
+C
+C
+C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
+C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
+C
+C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ IREJ=0
+C IF(IPIP.EQ.2)THEN
+C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
+C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
+C ENDIF
+C
+C
+C
+C determine x-values of NC1T diquark
+ XDIQT=PHKK(4,NC1T)*2.D0/UMO
+ XVQP=PHKK(4,NC1P)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
+ * UMO, XDIQT,XVQP
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQT/2.0D0
+ XAQMAX = 2.D0*XVQP/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQP/3.0D0
+ XAQMAX = XDIQT/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
+ & XDIQT,XVQP,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1T diquark and NC1P quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQT=XDIQT-XSQ
+ XVQP =XVQP -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQT=XDIQT-XSAQ
+ XVQP =XVQP -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
+C
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQT)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQII=XDIQT-XVTQI
+ ELSE
+ XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQI=XDIQT-XVTQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
+C
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ KK11=IP21
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ KK21=IPP11
+ KK22=IPP12
+ XGIVE=0.D0
+ IF(IPIP.EQ.1)THEN
+ IDHKT(4+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(4+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(4+IIGLU1) =961
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IDHKT(5+IIGLU1) =IP22
+ ISTHKT(5+IIGLU1) =962
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XXMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,5+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =96
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+C---------------------------------------------------
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+ IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
+C we drop chain 6 and give the energy to chain 3
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1'
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK11 to IDHKT(5)
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
+ KK11=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK21 to IDHKT(5+IIGLU1)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
+ KK21=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK22 to IDHKT(5)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
+ KK22=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ENDIF
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ 7788 CONTINUE
+C---------------------------------------------------
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IF(IPIP.EQ.1)THEN
+ IDHKT(1) =1000*KK21+100*KK22+3
+ IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
+ IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
+ IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(1) =1000*KK21+100*KK22-3
+ IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
+ IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
+ IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
+ ENDIF
+ ISTHKT(1) =961
+ JMOHKT(1,1)=NC2P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+ PHKT(1,1) =PHKK(1,NC2P)
+ *+XGIVE*PHKT(1,4+IIGLU1)
+ PHKT(2,1) =PHKK(2,NC2P)
+ *+XGIVE*PHKT(2,4+IIGLU1)
+ PHKT(3,1) =PHKK(3,NC2P)
+ *+XGIVE*PHKT(3,4+IIGLU1)
+ PHKT(4,1) =PHKK(4,NC2P)
+ *+XGIVE*PHKT(4,4+IIGLU1)
+C PHKT(5,1) =PHKK(5,NC2P)
+ XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC2P)
+ VHKT(2,1) =VHKK(2,NC2P)
+ VHKT(3,1) =VHKK(3,NC2P)
+ VHKT(4,1) =VHKK(4,NC2P)
+ WHKT(1,1) =WHKK(1,NC2P)
+ WHKT(2,1) =WHKK(2,NC2P)
+ WHKT(3,1) =WHKK(3,NC2P)
+ WHKT(4,1) =WHKK(4,NC2P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+C IDHKT(2) =IP21
+ IDHKT(2+IIGLU1) =KK11
+ ISTHKT(2+IIGLU1) =962
+ JMOHKT(1,2+IIGLU1)=NC1T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
+C * +0.5D0*PHKK(1,NC2T)
+ *+XGIVE*PHKT(1,5+IIGLU1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(2,NC2T)
+ *+XGIVE*PHKT(2,5+IIGLU1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(3,NC2T)
+ *+XGIVE*PHKT(3,5+IIGLU1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(4,NC2T)
+ *+XGIVE*PHKT(4,5+IIGLU1)
+C PHKT(5,2) =PHKK(5,NC1T)
+ XXMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,2+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =96
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(IPIP.EQ.3)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+ * JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+ * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
+ IDHKT(7+IIGLU1) =IP1
+ ISTHKT(7+IIGLU1) =961
+ JMOHKT(1,7+IIGLU1)=NC1P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+ PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
+C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,7+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,7+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C IDHKT(7) =1000*IPP1+100*ISQ+1
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+**NEW
+C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
+**
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
+ ENDIF
+ ISTHKT(8+IIGLU1+IIGLU2) =962
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
+ PHKT(1,8+IIGLU1+IIGLU2) =
+ * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(2,8+IIGLU1+IIGLU2) =
+ * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(3,8+IIGLU1+IIGLU2) =
+ * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(4,8+IIGLU1+IIGLU2) =
+ * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
+C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
+ IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,8) =PHKK(5,NC2T)
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =96
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
+ * PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+ * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
+ *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+ *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+
+*$ CREATE MUSQBS1.FOR
+*COPY MUSQBS1
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
+C
+C USQBS-1 diagram (split projectile diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+ COMMON /EVFLAG/ NUMEV
+C
+C USQBS-1 diagram (split projectile diquark)
+C
+C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
+C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
+C
+C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
+ CVQ=1.D0
+ IREJ=0
+ IF(IPIP.EQ.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+ * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
+ *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1P diquark
+ XDIQP=PHKK(4,NC1P)*2.D0/UMO
+ XVQT=PHKK(4,NC1T)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
+ * UMO, XDIQP,XVQT
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQP/2.0D0
+ XAQMAX = 2.D0*XVQT/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQT/3.0D0
+ XAQMAX = XDIQP/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
+**
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
+ & XDIQP,XVQT,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1P diquark and NC1T quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQP=XDIQP-XSQ
+ XVQT =XVQT -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQP=XDIQP-XSAQ
+ XVQT =XVQT -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
+C
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQP)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQII=XDIQP-XVPQI
+ ELSE
+ XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQI=XDIQP-XVPQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ IDHKT(1) =IP11
+ ISTHKT(1) =931
+ JMOHKT(1,1)=NC1P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+ PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
+C PHKT(5,1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC1P)
+ VHKT(2,1) =VHKK(2,NC1P)
+ VHKT(3,1) =VHKK(3,NC1P)
+ VHKT(4,1) =VHKK(4,NC1P)
+ WHKT(1,1) =WHKK(1,NC1P)
+ WHKT(2,1) =WHKK(2,NC1P)
+ WHKT(3,1) =WHKK(3,NC1P)
+ WHKT(4,1) =WHKK(4,NC1P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+ IDHKT(2+IIGLU1) =IPP2
+ ISTHKT(2+IIGLU1) =932
+ JMOHKT(1,2+IIGLU1)=NC2T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
+C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
+ XMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,2+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =94
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ XMIST
+ * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
+ * JMOHKT(2,1),JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+ * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IDHKT(4+IIGLU1) =IP12
+ ISTHKT(4+IIGLU1) =931
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,4+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(5+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(5+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(5+IIGLU1) =932
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
+C IF( PHKT(4,5).EQ.0.D0)THEN
+C IREJ=1
+CIPCO=0
+CRETURN
+C ENDIF
+C PHKT(5,5) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =94
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ XMIST
+ * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+C IF(IPIP.EQ.3)THEN
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 6',
+C & CHAMAL,PHKT(5,6+IIGLU1)
+ GO TO 3466
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
+ IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
+ IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
+ IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
+ IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
+ IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
+ IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
+C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
+ ENDIF
+ ISTHKT(7+IIGLU1) =931
+ JMOHKT(1,7+IIGLU1)=NC2P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
+C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
+ IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,7) =PHKK(5,NC2P)
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IDHKT(8+IIGLU1+IIGLU2) =IP2
+ ISTHKT(8+IIGLU1+IIGLU2) =932
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
+C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,8+IIGLU1+IIGLU2)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =94
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ XMIST
+ *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,9+IIGLU1+IIGLU2)
+ *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,
+ * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
+ * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
+ *JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+ *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 9',
+C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+
+*$ CREATE MGSQBS1.FOR
+*COPY MGSQBS1
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
+C
+C GSQBS-1 diagram (split projectile diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+C
+C GSQBS-1 diagram (split projectile diquark)
+C
+C
+C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
+C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
+C
+C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ NNNC1=IDHKK(NC1)/1000
+ MMMC1=IDHKK(NC1)-NNNC1*1000
+ KKKC1=ISTHKK(NC1)
+ NNNC2=IDHKK(NC2)/1000
+ MMMC2=IDHKK(NC2)-NNNC2*1000
+ KKKC2=ISTHKK(NC2)
+ IREJ=0
+ IF(IPIP.EQ.3)THEN
+ WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+ * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
+ *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1P diquark
+ XDIQP=PHKK(4,NC1P)*2.D0/UMO
+ XVQT=PHKK(4,NC1T)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
+ * UMO, XDIQP,XVQT
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQP/2.0D0
+ XAQMAX = 2.D0*XVQT/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQT/3.0D0
+ XAQMAX = XDIQP/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
+ & XDIQP,XVQT,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1P diquark and NC1T quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQP=XDIQP-XSQ
+**NEW
+C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
+**
+ XVQT =XVQT -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQP=XDIQP-XSAQ
+ XVQT =XVQT -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
+C
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQP)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQII=XDIQP-XVPQI
+ ELSE
+ XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQI=XDIQP-XVPQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
+ & XVTHR,XDIQP,XVPQI,XVPQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ KK11=IP11
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ KK21= IPP21
+ KK22= IPP22
+ XGIVE=0.D0
+ IDHKT(4+IIGLU1) =IP12
+ ISTHKT(4+IIGLU1) =921
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+**NEW
+ IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
+ & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
+**
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ * PHKT(1,4+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(5+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(5+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(5+IIGLU1) =922
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+**NEW
+ IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
+**
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+C IDHKT(6) =1000*NNNC1+MMMC1
+ ISTHKT(6+IIGLU1) =93
+C ISTHKT(6) =KKKC1
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+ IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
+C we drop chain 6 and give the energy to chain 3
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1'
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK11 to IDHKT(4)
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
+ KK11=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK21 to IDHKT(4)
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
+ KK21=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK22 to IDHKT(4)
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
+ KK22=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ENDIF
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 6'
+ GO TO 3466
+ ENDIF
+ 7788 CONTINUE
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),
+ * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),
+ * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),
+ * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(1) =IP11
+ IDHKT(1) =KK11
+ ISTHKT(1) =921
+ JMOHKT(1,1)=NC1P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+ PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(1,NC2P)
+ *+XGIVE*PHKT(1,4+IIGLU1)
+ PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(2,NC2P)
+ *+XGIVE*PHKT(2,4+IIGLU1)
+ PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(3,NC2P)
+ *+XGIVE*PHKT(3,4+IIGLU1)
+ PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(4,NC2P)
+ *+XGIVE*PHKT(4,4+IIGLU1)
+C PHKT(5,1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC1P)
+ VHKT(2,1) =VHKK(2,NC1P)
+ VHKT(3,1) =VHKK(3,NC1P)
+ VHKT(4,1) =VHKK(4,NC1P)
+ WHKT(1,1) =WHKK(1,NC1P)
+ WHKT(2,1) =WHKK(2,NC1P)
+ WHKT(3,1) =WHKK(3,NC1P)
+ WHKT(4,1) =WHKK(4,NC1P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IF(IPIP.EQ.1)THEN
+ IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
+ IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
+ IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
+ IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
+ IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
+ IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
+ IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
+ ENDIF
+ ISTHKT(2+IIGLU1) =922
+ JMOHKT(1,2+IIGLU1)=NC2T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
+ *+XGIVE*PHKT(1,5+IIGLU1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
+ *+XGIVE*PHKT(2,5+IIGLU1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
+ *+XGIVE*PHKT(3,5+IIGLU1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
+ *+XGIVE*PHKT(4,5+IIGLU1)
+C PHKT(5,2) =PHKK(5,NC2T)
+ XMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,2+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
+ IDHKT(3+IIGLU1) =88888
+C IDHKT(3) =1000*NNNC1+MMMC1+10
+ ISTHKT(3+IIGLU1) =93
+C ISTHKT(3) =KKKC1
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+ * JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
+ & IDHKT(2),JMOHKT(1,2+IIGLU1),
+ * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),
+ * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+**NEW
+C IF(IPIP.EQ.1)THEN
+C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
+C ELSEIF(IPIP.EQ.2)THEN
+C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
+C ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
+ ENDIF
+**
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
+ IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
+ IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
+ IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
+ IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
+ IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
+ IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
+C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
+ ENDIF
+ ISTHKT(7+IIGLU1) =921
+ JMOHKT(1,7+IIGLU1)=NC2P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
+**NEW
+ IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
+**
+ PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
+C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
+ IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,7) =PHKK(5,NC2P)
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IDHKT(8+IIGLU1+IIGLU2) =IP2
+ ISTHKT(8+IIGLU1+IIGLU2) =922
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+**NEW
+ IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
+**
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
+C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,8+IIGLU1+IIGLU2)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+C IDHKT(9) =1000*NNNC2+MMMC2+10
+ ISTHKT(9+IIGLU1+IIGLU2) =93
+C ISTHKT(9) =KKKC2
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
+ * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
+ * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
+ * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
+ * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
+ * PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),
+ * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+ * IDHKT(8+IIGLU1+IIGLU2),
+ * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
+ * JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),
+ * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
+ * JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 9',
+C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IGCOUN=9+IIGLU1+IIGLU2
+ IPCO=0
+ RETURN
+ END
+
+*$ CREATE HKKHKT.FOR
+*COPY HKKHKT
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+ SUBROUTINE HKKHKT(I,J)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+C
+ ISTHKK(I) =ISTHKT(J)
+ IDHKK(I) =IDHKT(J)
+C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
+ IF(IDHKK(I).EQ.88888)THEN
+C JMOHKK(1,I)=I-2
+C JMOHKK(2,I)=I-1
+ JMOHKK(1,I)=I-(J-JMOHKT(1,J))
+ JMOHKK(2,I)=I-(J-JMOHKT(2,J))
+ ELSE
+ JMOHKK(1,I)=JMOHKT(1,J)
+ JMOHKK(2,I)=JMOHKT(2,J)
+ ENDIF
+ JDAHKK(1,I)=JDAHKT(1,J)
+ JDAHKK(2,I)=JDAHKT(2,J)
+C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
+C JDAHKK(1,I)=I+2
+C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
+C JDAHKK(1,I)=I+1
+C ENDIF
+ IF(JDAHKT(1,J).GT.0)THEN
+ JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
+ ENDIF
+ PHKK(1,I) =PHKT(1,J)
+ PHKK(2,I) =PHKT(2,J)
+ PHKK(3,I) =PHKT(3,J)
+ PHKK(4,I) =PHKT(4,J)
+ PHKK(5,I) =PHKT(5,J)
+ VHKK(1,I) =VHKT(1,J)
+ VHKK(2,I) =VHKT(2,J)
+ VHKK(3,I) =VHKT(3,J)
+ VHKK(4,I) =VHKT(4,J)
+ WHKK(1,I) =WHKT(1,J)
+ WHKK(2,I) =WHKT(2,J)
+ WHKK(3,I) =WHKT(3,J)
+ WHKK(4,I) =WHKT(4,J)
+ RETURN
+ END
+
+*$ CREATE DT_DBREAK.FOR
+*COPY DT_DBREAK
+*
+*===dbreak=============================================================*
+*
+ SUBROUTINE DT_DBREAK(MODE)
+
+************************************************************************
+* This is the steering subroutine for the different diquark breaking *
+* mechanisms. *
+* *
+* MODE = 1 breaking of projectile diquark in qq-q chain using *
+* a sea quark (q-qq chain) of the same projectile *
+* = 2 breaking of target diquark in q-qq chain using *
+* a sea quark (qq-q chain) of the same target *
+* = 3 breaking of projectile diquark in qq-q chain using *
+* a sea quark (q-aq chain) of the same projectile *
+* = 4 breaking of target diquark in q-qq chain using *
+* a sea quark (aq-q chain) of the same target *
+* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
+* a sea anti-quark (aq-aqaq chain) of the same projectile *
+* = 6 breaking of target anti-diquark in aq-aqaq chain using *
+* a sea anti-quark (aqaq-aq chain) of the same target *
+* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
+* a sea anti-quark (aq-q chain) of the same projectile *
+* = 8 breaking of target anti-diquark in aq-aqaq chain using *
+* a sea anti-quark (q-aq chain) of the same target *
+* *
+* Original version by J. Ranft. *
+* This version dated 17.5.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* event history
+
+ PARAMETER (NMXHKK=200000)
+
+ COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+ & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+ & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+
+* extended event history
+ COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+ & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+ & IHIST(2,NMXHKK)
+
+* flags for input different options
+ LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+ COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+ & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
+ PARAMETER (MAXCHN=10000)
+ COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
+
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+* flags for particle decays
+ COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+ & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+ & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+
+*
+* chain identifiers
+* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
+* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
+ DIMENSION IDCHN1(8),IDCHN2(8)
+ DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
+ DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
+*
+* parton identifiers
+* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
+* +-51/52 = unitarity-sea, +-61/62 = gluons )
+ DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
+ DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
+ & 31, 31, 31, 31, 31, 31, 31, 31,
+ & 41, 41, 41, 41, 51, 51, 51, 51/
+ DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
+ & 32, 32, 32, 32, 32, 32, 32, 32,
+ & 42, 42, 42, 42, 52, 52, 52, 52/
+ DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
+ & 51, 31, 41, 41, 31, 31, 31, 31,
+ & 0, 41, 51, 51, 51, 51, 51, 51/
+ DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
+ & 32, 52, 42, 42, 32, 32, 32, 32,
+ & 42, 0, 52, 52, 52, 52, 52, 52/
+
+ IF (NCHAIN.LE.0) RETURN
+ DO 1 I=1,NCHAIN
+ IDX1 = IDXCHN(1,I)
+ IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
+ IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
+ IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
+ & .AND.
+ & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
+ & (IS1P.EQ.ISP1P(MODE,3)))
+ & .AND.
+ & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
+ & (IS1T.EQ.ISP1T(MODE,3)))
+ & ) THEN
+ DO 2 J=1,NCHAIN
+ IDX2 = IDXCHN(1,J)
+ IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
+ IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
+ IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
+ & .AND.
+ & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
+ & .OR.(IS2P.EQ.ISP2P(MODE,3)))
+ & .AND.
+ & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
+ & .OR.(IS2T.EQ.ISP2T(MODE,3)))
+ & ) THEN
+* find mother nucleons of the diquark to be splitted and of the
+* sea-quark and reject this combination if it is not the same
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
+ & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
+ IANCES = 1
+ ELSE
+ IANCES = 2
+ ENDIF
+ IDXMO1 = JMOHKK(IANCES,IDX1)
+ 4 CONTINUE
+ IF ((JMOHKK(1,IDXMO1).NE.0).AND.
+ & (JMOHKK(2,IDXMO1).NE.0)) THEN
+ IANC = IANCES
+ ELSE
+ IANC = 1
+ ENDIF
+ IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
+ IDXMO1 = JMOHKK(IANC,IDXMO1)
+ GOTO 4
+ ENDIF
+ IDXMO2 = JMOHKK(IANCES,IDX2)
+ 5 CONTINUE
+ IF ((JMOHKK(1,IDXMO2).NE.0).AND.
+ & (JMOHKK(2,IDXMO2).NE.0)) THEN
+ IANC = IANCES
+ ELSE
+ IANC = 1
+ ENDIF
+ IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
+ IDXMO2 = JMOHKK(IANC,IDXMO2)
+ GOTO 5
+ ENDIF
+ IF (IDXMO1.NE.IDXMO2) GOTO 2
+* quark content of projectile parton
+ IP1 = IDHKK(JMOHKK(1,IDX1))
+ IP11 = IP1/1000
+ IP12 = (IP1-1000*IP11)/100
+ IP2 = IDHKK(JMOHKK(2,IDX1))
+ IP21 = IP2/1000
+ IP22 = (IP2-1000*IP21)/100
+* quark content of target parton
+ IT1 = IDHKK(JMOHKK(1,IDX2))
+ IT11 = IT1/1000
+ IT12 = (IT1-1000*IT11)/100
+ IT2 = IDHKK(JMOHKK(2,IDX2))
+ IT21 = IT2/1000
+ IT22 = (IT2-1000*IT21)/100
+* split diquark and form new chains
+ IF (MODE.EQ.1) THEN
+ IF (IT1.EQ.4) GOTO 2
+ CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.2) THEN
+ IF (IT2.EQ.4) GOTO 2
+ CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.3) THEN
+ IF (IT1.EQ.4) GOTO 2
+ CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.4) THEN
+ IF (IT2.EQ.4) GOTO 2
+ CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.5) THEN
+ CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.6) THEN
+ CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.7) THEN
+ CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.8) THEN
+ CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
+ ENDIF
+ IF (IREJ.GE.1) THEN
+ if ((ipq.lt.0).or.(ipq.ge.4))
+ & write(LOUT,*) 'ipq !!!',ipq,mode
+ DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
+* accept or reject new chains corresponding to PDBSEA
+ ELSE
+ IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
+ ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
+ REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
+ ELSEIF (IPQ.EQ.3) THEN
+ ACC = DBRKA(3,MODE)
+ REJ = DBRKR(3,MODE)
+ ELSE
+ WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
+ STOP
+ ENDIF
+ IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
+ DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
+ IACC = 1
+ ELSE
+ DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
+ IACC = 0
+ ENDIF
+* new chains have been accepted and are now copied into HKKEVT
+ IF (IACC.EQ.1) THEN
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
+ & PHKK(3,IDX1),PHKK(4,IDX1),
+ & 1,IDUM1,IDUM2)
+ CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
+ & PHKK(3,IDX2),PHKK(4,IDX2),
+ & 2,IDUM1,IDUM2)
+ ENDIF
+ IDHKK(IDX1) = 99888
+ IDHKK(IDX2) = 99888
+ IDXCHN(2,I) = -1
+ IDXCHN(2,J) = -1
+ DO 3 K=1,IGCOUN
+ NHKK = NHKK+1
+ CALL HKKHKT(NHKK,K)
+ IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
+ PX = -PHKK(1,NHKK)
+ PY = -PHKK(2,NHKK)
+ PZ = -PHKK(3,NHKK)
+ PE = -PHKK(4,NHKK)
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ 3 CONTINUE
+ IF (LEMCCK) THEN
+ CHKLEV = 0.1D0
+ CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
+ & IREJ)
+ IF (IREJ.NE.0) CALL DT_EVTOUT(4)
+ ENDIF
+ GOTO 1
+ ENDIF
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ 1 CONTINUE
+ RETURN
+ END
+
+*$ CREATE DT_CQPAIR.FOR
+*COPY DT_CQPAIR
+*
+*===cqpair=============================================================*
+*
+ SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
+
+************************************************************************
+* This subroutine Creates a Quark-antiquark PAIR from the sea. *
+* *
+* XQMAX maxium energy fraction of quark (input) *
+* XAQMAX maxium energy fraction of antiquark (input) *
+* XQ energy fraction of quark (output) *
+* XAQ energy fraction of antiquark (output) *
+* IFLV quark flavour (- antiquark flavor) (output) *
+* *
+* This version dated 14.5.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 10 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+*
+ IREJ = 0
+ XQ = 0.0D0
+ XAQ = 0.0D0
+*
+* sample quark flavour
+*
+* set seasq here (the one from DTCHAI should be used in the future)
+ SEASQ = 0.5D0
+ IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
+*
+* sample energy fractions of sea pair
+* we first sample the energy fraction of a gluon and then split the gluon
+*
+* maximum energy fraction of the gluon forced via input
+ XGMAXI = XQMAX+XAQMAX
+* minimum energy fraction of the gluon
+ XTHR1 = 4.0D0 /UMO**2
+ XTHR2 = 0.54D0/UMO**1.5D0
+ XGMIN = MAX(XTHR1,XTHR2)
+* maximum energy fraction of the gluon
+ XGMAX = 0.3D0
+ XGMAX = MIN(XGMAXI,XGMAX)
+ IF (XGMIN.GE.XGMAX) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+*
+* sample energy fraction of the gluon
+ NLOOP = 0
+ 1 CONTINUE
+ NLOOP = NLOOP+1
+ IF (NLOOP.GE.50) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+ XGLUON = DT_SAMSQX(XGMIN,XGMAX)
+ EGLUON = XGLUON*UMO/2.0D0
+*
+* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
+ ZMIN = MIN(0.1D0,0.5D0/EGLUON)
+ ZMAX = 1.0D0-ZMIN
+ RZ = DT_RNDM(ZMAX)
+ XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
+ RQ = DT_RNDM(ZMAX)
+ IF (RQ.LT.0.5D0) THEN
+ XQ = XGLUON*XHLP
+ XAQ = XGLUON-XQ
+ ELSE
+ XAQ = XGLUON*XHLP
+ XQ = XGLUON-XAQ
+ ENDIF
+ IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
+
+ RETURN
+ END
--- /dev/null
+C***********************************************************************
+C
+C
+C
+C PHOJET version 1.12
+C -------------------
+C
+C
+C ($Revision: 1.12.1.35 $, $Date: 2000/06/25 21:59:19 $)
+C
+C
+C Authors: Ralph Engel
+C (ralph.engel@fzk.de)
+C
+C Johannes Ranft
+C (johannes.ranft@cern.ch)
+C
+C Stefan Roesler
+C (Stefan.Roesler@cern.ch)
+C
+C
+C For the latest version and documentation check
+C http://www-ik.fzk.de/~engel/phojet.html
+C
+C
+C Bug reports, questions, complaints are welcome
+C (please send a mail to ralph.engel@fzk.de).
+C
+C
+C Note that the code is available with several interfaces to
+C Lund fragmentation programs (JETSET7.x, 1.x and a double
+C precision JETSET version). This file is the code with
+C
+
+C interface to PYTHIA 6.1 (or higher)
+
+C for usage in DPMJET 3.x (Lund common block dimensions increased)
+
+C
+C***********************************************************************
+C
+C
+C List of subroutines and functions
+C ---------------------------------
+C
+C
+C main event simulation routines
+C
+C PHO_EVENT
+C PHO_PARTON
+C PHO_POSPOM
+C
+C PHO_STDPAR
+C PHO_POMSCA
+C
+C
+C user steering interface
+C
+C PHO_SETMDL
+C PHO_PRESEL
+C
+C
+C experimental setup / photon flux calculation
+C
+C PHO_FIXLAB
+C PHO_FIXCOL
+C PHO_GPHERA
+C PHO_GGEPEM
+C PHO_WGEPEM
+C PHO_GGBLSR
+C PHO_GGBEAM
+C PHO_GGHIOF
+C PHO_GGHIOG
+C PHO_GGFLCL
+C PHO_GGFLCR
+C PHO_GGFAUX
+C PHO_GGFNUC
+C PHO_GHHIOF
+C PHO_GHHIAS
+C
+C
+C initialization
+C
+C PHO_INIT
+C PHO_DATINI
+C PHO_PARDAT
+C PHO_MCINI
+C
+C PHO_EVEINI
+C
+C PHO_HARINI
+C PHO_FRAINI
+C
+C PHO_FITPAR
+C
+C
+C cross section calculation
+C
+C PHO_CSINT
+C
+C PHO_XSECT
+C PHO_BORNCS
+C PHO_HARXTO
+C
+C PHO_DSIGDT
+C
+C PHO_TRIREG
+C PHO_LOOREG
+C PHO_TRXPOM
+C
+C PHO_EIKON
+C PHO_CHAN2A
+C
+C PHO_SCALES
+C
+C
+C multiple interaction structure
+C
+C PHO_IMPAMP
+C PHO_PRBDIS
+C PHO_SAMPRO
+C PHO_SAMPRB
+C
+C
+C hadron / photon remnant treatment, soft x selection
+C
+C PHO_HARREM
+C PHO_PARREM
+C
+C PHO_HADSP2
+C PHO_HADSP3
+C PHO_SOFTXX
+C PHO_SELSXR
+C PHO_SELSX2
+C PHO_SELSXS
+C PHO_SELSXI
+C
+C PHO_VALFLA
+C PHO_REGFLA
+C PHO_SEAFLA
+C PHO_FLAUX
+C PHO_BETAF
+C IPHO_DIQU
+C
+C
+C primordial kt and soft parton pt
+C
+C PHO_PRIMKT
+C PHO_PARTPT
+C PHO_SOFTPT
+C PHO_SELPT
+C
+C PHO_CONN0
+C PHO_CONN1
+C
+C
+C simulation of hard scattering, initial state radiation
+C
+C PHO_HARCOL
+C PHO_SELCOL
+C PHO_HARCOR
+C
+C PHO_HARDIR
+C PHO_HARX12
+C PHO_HARDX1
+C PHO_HARKIN
+C PHO_HARWGH
+C PHO_HARSCA
+C PHO_HARFAC
+C PHO_HARWGX
+C PHO_HARWGI
+C PHO_HARINT
+C PHO_HARMCI
+C
+C PHO_HARXR3
+C PHO_HARXR2
+C PHO_HARXD2
+C PHO_HARXPT
+C PHO_HARISR
+C PHO_HARZSP
+C
+C PHO_PTCUT
+C PHO_ALPHAE
+C PHO_ALPHAS
+C
+C
+C diffraction dissociation
+C
+C PHO_DIFDIS
+C PHO_DIFPRO
+C PHO_DIFPAR
+C PHO_QELAST
+C PHO_CDIFF
+C PHO_DFWRAP
+C
+C PHO_SAMASS
+C PHO_DSIGDM
+C PHO_DFMASS
+C
+C PHO_SDECAY
+C PHO_SDECY2
+C PHO_SDECY3
+C
+C PHO_DIFSLP
+C PHO_DIFKIN
+C PHO_VECRES
+C PHO_DIFRES
+C
+C PHO_REGPAR
+C
+C PHO_PECMS
+C PHO_SETPAR
+C
+C
+C fragmentation, treatment of low-mass strings
+C
+C PHO_STRING
+C PHO_STRFRA
+C
+C PHO_ID2STR
+C PHO_MCHECK
+C PHO_POMCOR
+C PHO_MASCOR
+C PHO_PARCOR
+C
+C PHO_GLU2QU
+C PHO_GLUSPL
+C
+C PHO_DQMASS
+C PHO_BAMASS
+C PHO_MEMASS
+C
+C
+C particle code tables, particle numbering conversion
+C
+C PHO_PNAME
+C PHO_PMASS
+C IPHO_CHR3
+C IPHO_BAR3
+C
+C IPHO_ANTI
+C
+C IPHO_PDG2ID
+C IPHO_ID2PDG
+C IPHO_LU2PDG
+C IPHO_PDG2LU
+C
+C IPHO_CNV1
+C PHO_HACODE
+C
+C
+C
+C Lorentz transformations, rotations and mass adjustment
+C
+C PHO_ALTRA
+C PHO_LTRANS
+C PHO_TRANS
+C PHO_TRANI
+C
+C PHO_MKSLTR
+C PHO_GETLTR
+C
+C PHO_LTRHEP
+C
+C PHO_MSHELL
+C PHO_MASSAD
+C
+C
+C program debugging and internal cross-checks
+C
+C PHO_PREVNT
+C PHO_PRSTRG
+C PHO_CHECK
+C
+C PHO_TRACE
+C
+C PHO_REJSTA
+C
+C PHO_ABORT
+C
+C
+C cross section fitting
+C
+C PHO_FITMAI
+C PHO_FITINP
+C PHO_FITDAT
+C PHO_FITOUT
+C PHO_FITAMP
+C PHO_FITTST
+C PHO_FITMSQ
+C PHO_FITVD1
+C PHO_FITCN1
+C PHO_FITINI
+C
+C
+C cross section parametrizations
+C
+C PHO_HADCSL
+C PHO_ALLM97
+C PHO_CSDIFF
+C
+
+C
+C random numbers
+C
+
+C DPMJET random number generator DT_RNDM used
+
+C
+C PHO_SFECFE
+C PHO_RNDBET
+C PHO_RNDGAM
+C
+C
+C auxiliary routines / numerical methods
+C
+C PHO_GAUSET
+C PHO_GAUDAT
+C
+C pho_samp1d
+C
+C PHO_DZEROX
+C PHO_EXPINT
+C PHO_BESSJ0
+C PHO_BESSI0
+C pho_ExpBessI0
+C PHO_BESSI1
+C PHO_BESSK0
+C PHO_BESSK1
+C
+C PHO_XLAM
+C
+C PHO_SWAPD
+C PHO_SWAPI
+C
+C
+C parton density parametrization management / interface
+C
+C PHO_PDF
+C
+C PHO_SETPDF
+C PHO_GETPDF
+C PHO_ACTPDF
+C
+C PHO_QPMPDF
+C
+C PHO_PDFTST
+C
+C
+C parton density parametrizations from other authors
+C
+C PHO_DOR98LO
+C PHO_DOR98SC
+C PHO_DOR94LO
+C PHO_DOR94HO
+C PHO_DOR94DI
+C PHO_DOR92LO
+C PHO_DOR92HO
+C PHO_DORPLO
+C PHO_DORPHO
+C PHO_DORGLO
+C PHO_DORGHO
+C PHO_DORGH0
+C PHO_DOR94FV
+C PHO_DOR94FW
+C PHO_DOR94FS
+C PHO_DOR92FV
+C PHO_DOR92FW
+C PHO_DOR92FS
+C PHO_DORFVP
+C PHO_DORFGP
+C PHO_DORFQP
+C PHO_DORGF
+C PHO_DORGFS
+C PHO_grsf1
+C PHO_grsf2
+C
+C PHO_CKMTPA
+C PHO_CKMTPD
+C PHO_CKMTPO
+C PHO_CKMTFV
+C
+C PHO_DBFINT
+C
+C PHO_SASGAM
+C PHO_SASVMD
+C PHO_SASANO
+C PHO_SASBEH
+C PHO_SASDIR
+C
+C PHO_PHGAL
+C PHVAL
+C
+C
+C***********************************************************************
+
+*$ CREATE PHO_INIT.FOR
+*COPY PHO_INIT
+CDECK ID>, PHO_INIT
+ SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
+C***********************************************************************
+C
+C main subroutine to configure and manage PHOJET calculations
+C
+C input: LINP input unit to read from
+C -1 to skip reading of input file
+C LOUT output unit to write to
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER KCHG
+ DOUBLE PRECISION PMAS,PARF,VCKM
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+ INTEGER PYCOMP
+
+ DIMENSION ITMP(0:11)
+ CHARACTER*10 CNAME
+ CHARACTER*70 NUMBER,FILENA
+
+ 14 FORMAT(A10,A69)
+ 15 FORMAT(A12)
+
+C define input/output units
+ IF(LINP.GE.0) THEN
+ LI = LINP
+ ELSE
+ LI = 5
+ ENDIF
+ LO = LOUT
+
+ IREJ = 0
+
+ WRITE(LO,*)
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' '
+ WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
+ WRITE(LO,*) ' '
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' Authors: Ralph Engel (FZ Karlsruhe)'
+ WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
+ WRITE(LO,*) ' Stefan Roesler (CERN)'
+ WRITE(LO,*) ' ---------------------------------------------------'
+ WRITE(LO,*) ' Manual, updates, and further information:'
+ WRITE(LO,*) ' http://www-ik.fzk.de/~engel/phojet.html'
+ WRITE(LO,*) ' ---------------------------------------------------'
+ WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
+ WRITE(LO,*) ' ralph.engel@fzk.de'
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' $Date: 2000/06/25 21:59:19 $'
+ WRITE(LO,*) ' $Revision: 1.12.1.35 $'
+
+ WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
+
+ WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
+
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*)
+
+C standard initializations
+ CALL PHO_DATINI
+ CALL PHO_PARDAT
+ DUM = PHO_PMASS(0,-1)
+
+C initialize standard PDFs
+C proton
+ CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
+ CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
+C neutron
+ CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
+ CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
+C photon
+ CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
+C pomeron
+ CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
+C pions
+ CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
+C kaons
+ CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
+
+C nothing to be done
+ IF(LINP.LT.0) RETURN
+
+C main loop to read input cards
+ 1200 CONTINUE
+ READ(LINP,14,END=1300) CNAME,NUMBER
+ IF(CNAME.EQ.'ENDINPUT ') THEN
+ GOTO 1300
+ ELSE IF(CNAME.EQ.'STOP ') THEN
+ WRITE(LO,*) 'STOP'
+ STOP
+ ELSE IF(CNAME.EQ.'COMMENT ') THEN
+ WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
+ ELSE IF(CNAME(1:1).EQ.'*') THEN
+ WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
+ ELSE IF(CNAME.EQ.'PTCUT ') THEN
+ READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
+ WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
+ & PARMDL(38),PARMDL(39)
+ ELSE IF(CNAME.EQ.'PROCESS ') THEN
+ READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
+ WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
+ ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
+ READ(NUMBER,*) (ITMP(KK),KK=0,11)
+ WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
+ DO 112 KK=1,8
+ IPRON(KK,ITMP(0)) = ITMP(KK)
+ 112 CONTINUE
+ ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
+ READ(NUMBER,*) IMPRO,IP,ION
+ WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
+ MH_pro_on(IMPRO,IP) = ION
+ ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
+ READ(NUMBER,*) IDPDG,PVIR
+ IHFLS(1) = 1
+ XPSUB = 1.D0
+ CALL PHO_SETPAR(1,IDPDG,0,PVIR)
+ WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
+ ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
+ READ(NUMBER,*) IDPDG,PVIR
+ IHFLS(2) = 1
+ XTSUB = 1.D0
+ CALL PHO_SETPAR(2,IDPDG,0,PVIR)
+ WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
+ ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
+ READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
+ IHFLS(1) = IVAL
+ IHFLD(1,1) = IFL1
+ IHFLD(1,2) = IFL2
+ XPSUB = XSUB
+ PVIR = 0.D0
+ CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
+ WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
+ ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
+ READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
+ IHFLS(2) = IVAL
+ IHFLD(2,1) = IFL1
+ IHFLD(2,2) = IFL2
+ XTSUB = XSUB
+ PVIR = 0.D0
+ CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
+ WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
+ ELSE IF(CNAME.EQ.'PDF ') THEN
+ READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
+ WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
+ CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
+ ELSE IF(CNAME.EQ.'SETMODEL ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'SETMODEL ',I,IVAL
+ CALL PHO_SETMDL(I,IVAL,1)
+ ELSE IF(CNAME.EQ.'SETPARAM ') THEN
+ READ(NUMBER,*) I,PARNEW
+ WRITE(LO,*) 'SETPARAM ',I,PARNEW
+ PARMDL(I) = PARNEW
+ ELSE IF(CNAME.EQ.'DEBUG ') THEN
+ READ(NUMBER,*) IDEBF,IDEBN,IDLEV
+ WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
+ CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
+ ELSE IF(CNAME.EQ.'TRACE ') THEN
+ READ(NUMBER,*) IDEBF,IDLEV
+ WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
+ IDEB(IDEBF) = IDLEV
+ ELSE IF(CNAME.EQ.'SETICUT ') THEN
+ READ(NUMBER,*) I,ICUT
+ WRITE(LO,*) 'SETICUT ',I,ICUT
+ ISWCUT(I) = ICUT
+ ELSE IF(CNAME.EQ.'SETFCUT ') THEN
+ READ(NUMBER,*) I,PARNEW
+ WRITE(LO,*) 'SETFCUT ',I,PARNEW
+ HSWCUT(I) = PARNEW
+ ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'LUND-MSTU ',I,IVAL
+ MSTU(I) = IVAL
+ ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
+ MSTJ(I) = IVAL
+ ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
+ READ(NUMBER,*) I,EE
+ WRITE(LO,*) 'LUND-PARJ ',I,EE
+ PARJ(I) = REAL(EE)
+ ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
+ READ(NUMBER,*) I,EE
+ WRITE(LO,*) 'LUND-PARU ',I,EE
+ PARU(I) = REAL(EE)
+ ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
+ READ(NUMBER,*) ID,ION
+ WRITE(LO,*) 'LUND-DECAY ',ID,ION
+
+ KC=PYCOMP(ID)
+
+ MDCY(KC,1) = ION
+ ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
+ READ(NUMBER,*) PSOMIN
+ WRITE(LO,*) 'PSOFTMIN ',PSOMIN
+ ELSE IF(CNAME.EQ.'INTPREC ') THEN
+ READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+
+C PDF test utility
+ ELSE IF(CNAME.EQ.'PDFTEST ') THEN
+ READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
+ PVIRT2 = ABS(PVIRT2)
+ WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
+ CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
+
+C mass cut on gamma-gamma or gamma-hadron system
+ ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
+ READ(NUMBER,*) ECMIN,ECMAX
+ WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
+
+C beam lepton (anti-)tagging system
+ ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
+ READ(NUMBER,*) ITAG1,ITAG2
+ WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
+ ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
+ READ(NUMBER,*)
+ & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
+ WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
+ & Q2MIN1,Q2MAX1,THMIN1,THMAX1
+ ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
+ READ(NUMBER,*)
+ & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
+ WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
+ & Q2MIN2,Q2MAX2,THMIN2,THMAX2
+
+C sampling of gamma-p events in ep (HERA)
+ ELSE IF( (CNAME.EQ.'WW-HERA ')
+ & .OR.(CNAME.EQ.'GP-HERA ')) THEN
+ READ(NUMBER,*) EE1,EE2,NEV
+ WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
+ IF(YMAX2.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
+ ELSE
+ CALL PHO_GPHERA(NEV,EE1,EE2)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-gamma events in e+e- (LEP)
+ ELSE IF( (CNAME.EQ.'GG-EPEM ')
+ & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
+ READ(NUMBER,*) EE1,EE2,NEV
+ WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
+ ELSE
+ CALL PHO_GGEPEM(-1,EE1,EE2)
+ CALL PHO_GGEPEM(NEV,EE1,EE2)
+ CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-gamma in heavy-ion collisions
+ ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GGHIOF(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+ ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GGHIOG(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-hadron events in heavy ion collisions
+ ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GHHIOF(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of hadron-gamma events in hadron - heavy ion collisions
+ ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
+ READ(NUMBER,*) EP,EE,NA,NZ,NEV
+ WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
+ IF(YMAX2.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of photoproduction events e+e-, backscattered laser
+ ELSE IF(CNAME.EQ.'BLASER ') THEN
+ READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
+ WRITE(LO,*) 'BLASER ',EE1,EE2,
+ & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
+ CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
+ KEVENT = 0
+
+C sampling of photoproduction events beamstrahlung
+ ELSE IF(CNAME.EQ.'BEAMST ') THEN
+ READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
+ WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
+ IF(YMAX1.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
+ ELSE
+ CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
+ KEVENT = 0
+ ENDIF
+
+C fixed-energy events in LAB system of particle 2
+ ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
+ READ(NUMBER,*) PLAB,NEV
+ WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
+ CALL PHO_FIXLAB(PLAB,NEV)
+ KEVENT = 0
+
+C fixed-energy events in CM system
+ ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
+ READ(NUMBER,*) ECM,NEV
+ WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
+ PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
+ PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
+ CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
+ E1 = EE
+ E2 = ECM-EE
+ THETA = 0.D0
+ PHI = 0.D0
+ CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+ KEVENT = 0
+
+C fixed-energy events for collider setup with crossing angle
+ ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
+ READ(NUMBER,*) E1,E2,THETA,PHI,NEV
+ WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
+ CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+ KEVENT = 0
+
+C unknown data card
+ ELSE
+ WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
+ ENDIF
+
+ GOTO 1200
+ 1300 CONTINUE
+ WRITE(LO,*) ' RETURN'
+
+ END
+
+*$ CREATE PHO_SETMDL.FOR
+*COPY PHO_SETMDL
+CDECK ID>, PHO_SETMDL
+ SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
+C**********************************************************************
+C
+C set model switches
+C
+C input: INDX model parameter number
+C (positive: ISWMDL, negative: IPAMDL)
+C IVAL new value
+C IMODE -1 print value of parameter INDX
+C 1 set new value
+C -2 print current settings
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ IF(IMODE.EQ.-2) THEN
+ WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
+ & '----------------------------'
+ DO 100 I=1,48,3
+ IF(ISWMDL(I).EQ.-9999) GOTO 200
+ IF(ISWMDL(I+1).EQ.-9999) THEN
+ WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
+ GOTO 200
+ ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
+ WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
+ & I+1,':',MDLNA(I+1),ISWMDL(I+1)
+ GOTO 200
+ ELSE
+ WRITE(LO,'(3(5X,I3,A1,A,I6))')
+ & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
+ ENDIF
+ 100 CONTINUE
+ 200 CONTINUE
+ ELSE IF(IMODE.EQ.-1) THEN
+ WRITE(LO,'(1X,A,1X,A,I6)')
+ & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
+ ELSE IF(IMODE.EQ.1) THEN
+ IF(INDX.GT.0) THEN
+ IF(ISWMDL(INDX).NE.IVAL) THEN
+ WRITE(LO,'(1X,A,I4,1X,A,2I6)')
+ & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
+ & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
+ ISWMDL(INDX) = IVAL
+ ENDIF
+ ELSE IF(INDX.LT.0) THEN
+ IF(IPAMDL(-INDX).NE.IVAL) THEN
+ WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
+ & -INDX,IPAMDL(-INDX),IVAL
+ IPAMDL(-INDX) = IVAL
+ ENDIF
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,I6)')
+ & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
+ ENDIF
+ END
+
+*$ CREATE PHO_DATINI.FOR
+*COPY PHO_DATINI
+CDECK ID>, PHO_DATINI
+ SUBROUTINE PHO_DATINI
+C*********************************************************************
+C
+C initialization of variables and switches
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+
+C initialize /POCONS/
+ PI = ATAN(1.D0)*4.D0
+ PI2 = 2.D0*PI
+ PI4 = 2.D0*PI2
+C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
+ GEV2MB = 0.389365D0
+C precalculate quark charges
+ do i=1,6
+ Q_ch(i) = dble(2-3*mod(i,2))/3.D0
+ Q_ch(-i) = -Q_ch(i)
+
+ Q_ch2(i) = Q_ch(i)**2
+ Q_ch2(-i) = Q_ch2(i)
+
+ Q_ch4(i) = Q_ch2(i)**2
+ Q_ch4(-i) = Q_ch4(i)
+ enddo
+ Q_ch(0) = 0.D0
+ Q_ch2(0) = 0.D0
+ Q_ch4(0) = 0.D0
+
+C initialize /GLOCMS/
+ ECM = 50.D0
+ PMASS(1) = 0.D0
+ PVIRT(1) = 0.D0
+ PMASS(2) = 0.D0
+ PVIRT(2) = 0.D0
+ IFPAP(1) = 22
+ IFPAP(2) = 22
+C initialize /HADVAL/
+ IHFLD(1,1) = 0
+ IHFLD(1,2) = 0
+ IHFLD(2,1) = 0
+ IHFLD(2,2) = 0
+ IHFLS(1) = 1
+ IHFLS(2) = 1
+C initialize /MODELS/
+ ISWMDL(1) = 3
+ MDLNA(1) = 'AMPL MOD'
+ ISWMDL(2) = 1
+ MDLNA(2) = 'MIN-BIAS'
+ ISWMDL(3) = 1
+ MDLNA(3) = 'PTS DISH'
+ ISWMDL(4) = 1
+ MDLNA(4) = 'PTS DISP'
+ ISWMDL(5) = 2
+ MDLNA(5) = 'PTS ASSI'
+ ISWMDL(6) = 3
+ MDLNA(6) = 'HADRONIZ'
+ ISWMDL(7) = 2
+ MDLNA(7) = 'MASS COR'
+ ISWMDL(8) = 3
+ MDLNA(8) = 'PAR SHOW'
+ ISWMDL(9) = 0
+ MDLNA(9) = 'GLU SPLI'
+ ISWMDL(10) = 2
+ MDLNA(10) = 'VIRT PHO'
+ ISWMDL(11) = 0
+ MDLNA(11) = 'LARGE NC'
+ ISWMDL(12) = 0
+ MDLNA(12) = 'LIPA POM'
+ ISWMDL(13) = 1
+ MDLNA(13) = 'QELAS VM'
+ ISWMDL(14) = 2
+ MDLNA(14) = 'ENHA GRA'
+ ISWMDL(15) = 4
+ MDLNA(15) = 'MULT SCA'
+ ISWMDL(16) = 4
+ MDLNA(16) = 'MULT DIF'
+ ISWMDL(17) = 4
+ MDLNA(17) = 'MULT CDF'
+ ISWMDL(18) = 0
+ MDLNA(18) = 'BALAN PT'
+ ISWMDL(19) = 1
+ MDLNA(19) = 'POMV FLA'
+ ISWMDL(20) = 0
+ MDLNA(20) = 'SEA FLA'
+ ISWMDL(21) = 2
+ MDLNA(21) = 'SPIN DEC'
+ ISWMDL(22) = 1
+ MDLNA(22) = 'DIF.MASS'
+ ISWMDL(23) = 1
+ MDLNA(23) = 'DIFF RES'
+ ISWMDL(24) = 0
+ MDLNA(24) = 'PTS HPOM'
+ ISWMDL(25) = 0
+ MDLNA(25) = 'POM CORR'
+ ISWMDL(26) = 1
+ MDLNA(26) = 'OVERLAP '
+ ISWMDL(27) = 0
+ MDLNA(27) = 'MUL R/AN'
+ ISWMDL(28) = 1
+ MDLNA(28) = 'SUR PROB'
+ ISWMDL(29) = 1
+ MDLNA(29) = 'PRIMO KT'
+ ISWMDL(30) = 0
+ MDLNA(30) = 'DIFF. CS'
+ ISWMDL(31) = -9999
+C mass-independent sea flavour ratios (for low-mass strings)
+ PARMDL(1) = 0.425D0
+ PARMDL(2) = 0.425D0
+ PARMDL(3) = 0.15D0
+ PARMDL(4) = 0.D0
+ PARMDL(5) = 0.D0
+ PARMDL(6) = 0.D0
+C suppression by energy momentum conservation
+ PARMDL(8) = 9.D0
+ PARMDL(9) = 7.D0
+C VDM factors
+ PARMDL(10) = 0.866D0
+ PARMDL(11) = 0.288D0
+ PARMDL(12) = 0.288D0
+ PARMDL(13) = 0.288D0
+ PARMDL(14) = 0.866D0
+ PARMDL(15) = 0.288D0
+ PARMDL(16) = 0.288D0
+ PARMDL(17) = 0.288D0
+ PARMDL(18) = 0.D0
+C lower energy limit for initialization
+ PARMDL(19) = 5.D0
+C soft pt for hard scattering remnants
+ PARMDL(20) = 5.D0
+C low energy beta of soft pt distribution 1
+ PARMDL(21) = 4.5D0
+C high energy beta of soft pt distribution 1
+ PARMDL(22) = 3.0D0
+C low energy beta of soft pt distribution 0
+ PARMDL(23) = 2.5D0
+C high energy beta of soft pt distribution 0
+ PARMDL(24) = 0.4D0
+C effective quark mass in photon wave function
+ PARMDL(25) = 0.2D0
+C normalization of unevolved Pomeron PDFs
+ PARMDL(26) = 0.3D0
+C effective VDM parameters for Q**2 dependence of cross section
+ PARMDL(27) = 0.65D0
+ PARMDL(28) = 0.08D0
+ PARMDL(29) = 0.05D0
+ PARMDL(30) = 0.22D0
+ PARMDL(31) = 0.589824D0
+ PARMDL(32) = 0.609961D0
+ PARMDL(33) = 1.038361D0
+ PARMDL(34) = 1.96D0
+C Q**2 suppression of multiple interactions
+ PARMDL(35) = 0.59D0
+C pt cutoff defaults
+ PARMDL(36) = 2.5D0
+ PARMDL(37) = 2.5D0
+ PARMDL(38) = 2.5D0
+ PARMDL(39) = 2.5D0
+C enhancement factor for diffractive cross sections
+ PARMDL(40) = 1.D0
+ PARMDL(41) = 1.D0
+ PARMDL(42) = 1.D0
+C mass in soft pt distribution
+ PARMDL(43) = 0.D0
+C maximum of x allowed for leading particle
+ PARMDL(44) = 0.9D0
+C max. mass sampled in diffraction
+ PARMDL(45) = sqrt(0.4D0)
+C mass threshold in diffraction (2pi mass)
+ PARMDL(46) = 0.3D0
+C regularization of slope parameter in diffraction
+ PARMDL(47) = 4.D0
+C renormalized intercept for enhanced graphs
+ PARMDL(48) = 1.08D0
+C coherence constraint for diff. cross sections
+ PARMDL(49) = sqrt(0.05D0)
+C exponents of x distributions
+C baryon
+ PARMDL(50) = 1.5D0
+ PARMDL(51) = -0.5D0
+ PARMDL(52) = -0.99D0
+ PARMDL(53) = -0.99D0
+C meson (non-strangeness part)
+ PARMDL(54) = -0.5D0
+ PARMDL(55) = -0.5D0
+ PARMDL(56) = -0.99D0
+ PARMDL(57) = -0.99D0
+C meson (strangeness part)
+ PARMDL(58) = -0.2D0
+ PARMDL(59) = -0.2D0
+ PARMDL(60) = -0.99D0
+ PARMDL(61) = -0.99D0
+C particle remnant (no valence quarks)
+ PARMDL(62) = -0.5D0
+ PARMDL(63) = -0.5D0
+ PARMDL(64) = -0.99D0
+ PARMDL(65) = -0.99D0
+C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
+ PARMDL(66) = 10.D0
+C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
+ PARMDL(67) = 10.D0
+C min. abs(t) in diffraction
+ PARMDL(68) = 0.D0
+C max. abs(t) in diffraction
+ PARMDL(69) = 10.D0
+C min. mass for elastic pomerons in central diffraction
+ PARMDL(70) = 2.D0
+C min. mass of diffractive blob in central diffraction
+ PARMDL(71) = 2.D0
+C min. Feynman x cut in central diffraction
+ PARMDL(72) = 0.D0
+C direct pomeron coupling
+ PARMDL(74) = 0.D0
+C relative deviation allowed for energy-momentum conservation
+C energy-momentum relative deviation
+ PARMDL(75) = 0.01D0
+C transverse momentum deviation
+ PARMDL(76) = 0.01D0
+C couplings for unitarization in diffraction
+C non-unitarized pomeron coupling (sqrt(mb))
+ PARMDL(77) = 3.D0
+C rescaling factor for pomeron PDF
+ PARMDL(78) = 3.D0
+C coupling probabilities
+ PARMDL(79) = 1.D0
+ PARMDL(80) = 0.D0
+C scales to calculate alpha-s of matrix element
+ PARMDL(81) = 1.D0
+ PARMDL(82) = 1.D0
+ PARMDL(83) = 1.D0
+C scales to calculate alpha-s of initial state radiation
+ PARMDL(84) = 1.D0
+ PARMDL(85) = 1.D0
+ PARMDL(86) = 1.D0
+C scales to calculate alpha-s of final state radiation
+ PARMDL(87) = 1.D0
+ PARMDL(88) = 1.D0
+ PARMDL(89) = 1.D0
+C scales to calculate PDFs
+ PARMDL(90) = 1.D0
+ PARMDL(91) = 1.D0
+ PARMDL(92) = 1.D0
+C scale for ISR starting virtuality
+ PARMDL(93) = 1.D0
+C min. virtuality to generate time-like showers in ISR
+ PARMDL(94) = 2.D0
+C factor to scale the max. allowed time-like parton shower virtuality
+ PARMDL(95) = 4.D0
+C max. transverse momentum for primordial kt
+ PARMDL(100) = 2.D0
+C weight factors for pt-distribution
+ PARMDL(101) = 2.D0
+ PARMDL(102) = 2.D0
+ PARMDL(103) = 4.D0
+ PARMDL(104) = 2.D0
+ PARMDL(105) = 6.D0
+ PARMDL(106) = 4.D0
+C
+* PARMDL(110-125) reserved for hard scattering
+C currently chosen scales for hard scattering
+ DO 10 I=1,16
+ PARMDL(109+I) = 0.D0
+ 10 CONTINUE
+C virtuality cutoff in initial state evolution
+ PARMDL(126) = PARMDL(36)**2
+ PARMDL(127) = PARMDL(37)**2
+ PARMDL(128) = PARMDL(38)**2
+ PARMDL(129) = PARMDL(39)**2
+C virtuality cutoff for direct contribution to photon PDF
+ PARMDL(130) = 1.D30
+ PARMDL(131) = 1.D30
+ PARMDL(132) = 1.D30
+ PARMDL(133) = 1.D30
+C fraction of events without popcorn
+ PARMDL(134) = -1.D0
+C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
+ PARMDL(135) = 0.5D0
+C soft color re-connection (fraction)
+C g g final state
+ PARMDL(140) = 1.D0/64.D0
+C g q final state
+ PARMDL(141) = 1.D0/24.D0
+C q q final state
+ PARMDL(142) = 1.D0/9.D0
+C effective scale in Drees-Godbole like suppresion in photon PDF
+ PARMDL(144) = 0.766D0**2
+C QCD scales (if PDF scales are not used, 4 active flavours)
+ PARMDL(145) = 0.2D0**2
+ PARMDL(146) = 0.2D0**2
+ PARMDL(147) = 0.2D0**2
+C threshold scales for variable flavour calculation (GeV**2)
+ PARMDL(148) = 1.5D0**2
+ PARMDL(149) = 4.5D0**2
+ PARMDL(150) = 175.D0**2
+C constituent quark masses
+ PARMDL(151) = 0.3D0
+ PARMDL(152) = 0.3D0
+ PARMDL(153) = 0.5D0
+ PARMDL(154) = 1.6D0
+ PARMDL(155) = 5.D0
+ PARMDL(156) = 174.D0
+C min. masses of valence quark
+ PARMDL(157) = 0.3D0
+C min. masses of valence diquark
+ PARMDL(158) = 0.8D0
+C min. mass of sea quark
+ PARMDL(159) = 0.D0
+C suppression of strange quarks as photon valences
+ PARMDL(160) = 0.2D0
+C min. masses for strings (used in PHO_SOFTXX)
+ PARMDL(161) = 1.D0
+ PARMDL(162) = 1.D0
+ PARMDL(163) = 1.D0
+ PARMDL(164) = 1.D0
+C min. momentum fraction for soft processes
+ PARMDL(165) = 0.3D0
+C min. phase space for x-sampling
+ PARMDL(166) = 0.135D0
+C Ross-Stodolsky exponent
+ PARMDL(170) = 4.2D0
+C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
+ PARMDL(175) = 2.D0
+
+**sr
+* extra factor multiplying difference between Goulianos and PHOJET-
+* diff. cross sections
+ PARMDL(200) = 0.6D0
+**
+
+C complex amplitudes, eikonal functions
+ IPAMDL(1) = 0
+C allow for Reggeon cuts
+ IPAMDL(2) = 1
+C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
+ IPAMDL(3) = 0
+C polarization of photon resonances (0 none, 1 trans, 2 long)
+ IPAMDL(4) = 1
+C pt of valence partons
+ IPAMDL(5) = 1
+C pt of hard scattering remnant
+ IPAMDL(6) = 2
+C running cutoff for hard scattering
+ IPAMDL(7) = 1
+C intercept used for the calculation of enhanced graphs
+ IPAMDL(8) = 1
+C effective slope of hard scattering amplitde
+ IPAMDL(9) = 1
+C mass dependence of slope parameters
+ IPAMDL(10) = 0
+C lepton-photon vertex 1
+ IPAMDL(11) = 0
+C lepton-photon vertex 2
+ IPAMDL(12) = 0
+C call by DPMJET
+ IPAMDL(13) = 0
+C method to sample x distributions
+ IPAMDL(14) = 3
+C energy-momentum check
+ IPAMDL(15) = 1
+C phase space correction for DPMJET interface
+ IPAMDL(16) = 1
+C fragment strings from projectile/target/central diff. separately
+ IPAMDL(17) = 1
+C method to construct strings for hard interactions
+ IPAMDL(18) = 1
+C method to construct strings for soft sea (pomeron cuts)
+ IPAMDL(19) = 0
+C method to construct strings in pomeron interactions
+ IPAMDL(20) = 0
+C soft color re-connection
+ IPAMDL(21) = 0
+C resummation of triple- and loop-Pomeron
+ IPAMDL(24) = 1
+C resummation of X iterated triple-Pomeron
+ IPAMDL(25) = 1
+C dimension of interpolation table for weights in hard scattering
+ IPAMDL(30) = Max_tab_E
+C dimension of interpolation table for pomeron cut distribution
+ IPAMDL(31) = IEETA1
+C number of cut soft pomerons (restriction by field dimension)
+ IPAMDL(32) = IIMAX
+C number of cut hard pomerons (restriction by field dimension)
+ IPAMDL(33) = KKMAX
+C tau pair production in direct photon-photon collisions
+ IPAMDL(64) = 0
+C currently chosen scales for hard scattering
+C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
+ DO 15 I=1,16
+ IPAMDL(64+I) = -99999
+ 15 CONTINUE
+C scales to calculate alpha-s of matrix element
+ IPAMDL(81) = 1
+ IPAMDL(82) = 1
+ IPAMDL(83) = 1
+C scales to calculate alpha-s of initial state radiation
+ IPAMDL(84) = 1
+ IPAMDL(85) = 1
+ IPAMDL(86) = 1
+C scales to calculate alpha-s of final state radiation
+ IPAMDL(87) = 1
+ IPAMDL(88) = 1
+ IPAMDL(89) = 1
+C scales to calculate PDFs
+ IPAMDL(90) = 1
+ IPAMDL(91) = 1
+ IPAMDL(92) = 1
+C where to get the parameter sets from
+ IPAMDL(99) = 1
+C program PHO_ABORT for fatal errors (simulation of division by zero)
+ IPAMDL(100) = 0
+C initial state parton showers for all / hardest interaction(s)
+ IPAMDL(101) = 1
+C final state parton showers for all / hardest interaction(s)
+ IPAMDL(102) = 1
+C initial virtuality for ISR generation
+ IPAMDL(109) = 1
+C qqbar-gamma coupling in initial state showers
+ IPAMDL(110) = 1
+C generation of time-like showers during ISR
+ IPAMDL(111) = 1
+C reweighting of multiple soft contributions for virtual photons
+ IPAMDL(114) = 1
+C reweighting / use photon virtuality in photon PDF calculations
+ IPAMDL(115) = 0
+C use full QPM model incl. interference terms (direct part in gam-gam)
+ IPAMDL(116) = 0
+C matching sigma_tot to F2 as given by parton density at high Q2
+ IPAMDL(117) = 1
+C use virtuality of target in F2 calculations (two-gamma only)
+ IPAMDL(118) = 1
+C calculation of alpha_em
+ IPAMDL(120) = 1
+C strict pt cutoff for gamma-gamma events
+ IPAMDL(121) = 0
+C photon virtuality sampled in photon flux approximations
+ IPAMDL(174) = 1
+C photon-pomeron: 0,1,2: both,left,right photon emission
+ IPAMDL(175) = 0
+C keep full history information in PHOJET-JETSET interface
+ IPAMDL(178) = 1
+C max. number of conservation law violations allowed in one run
+ IPAMDL(179) = 20
+C selection of soft X values
+C max. iteration number in PHO_SELSXS
+ IPAMDL(180) = 50
+C max. iteration number in PHO_SELSXR
+ IPAMDL(181) = 200
+C max. iteration number in PHO_SELSX2
+ IPAMDL(182) = 100
+C max. iteration number in PHO_SELSXI
+ IPAMDL(183) = 50
+
+C initialize /PROBAB/
+ IEEMAX = IEETA1
+ IMAX = IIMAX
+ KMAX = KKMAX
+
+ DO 20 I=1,30
+ PARMDL(300+I) = -100000.D0
+ 20 CONTINUE
+C initialize /POHDRN/
+ QMASS(1) = PARMDL(151)
+ QMASS(2) = PARMDL(152)
+ QMASS(3) = PARMDL(153)
+ QMASS(4) = PARMDL(154)
+ QMASS(5) = PARMDL(155)
+ QMASS(6) = PARMDL(156)
+ BET = 8.D0
+ PCOUDI = 0.D0
+ VALPRG(1) = 1.D0
+ VALPRG(2) = 1.D0
+C number of light flavours (quarks treated as massless)
+ NFS = 4
+C initialize /POCUT1/
+ PTCUT(1) = PARMDL(36)
+ PTCUT(2) = PARMDL(37)
+ PTCUT(3) = PARMDL(38)
+ PTCUT(4) = PARMDL(39)
+ PSOMIN = 0.D0
+ XSOMIN = 0.D0
+C initialize /POHAPA/
+ NFbeta = 4
+ NF = 4
+ BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
+ BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
+ BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
+ BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
+C initialize /POGAUP/
+ NGAUP1 = 12
+ NGAUP2 = 12
+ NGAUET = 16
+ NGAUIN = 12
+ NGAUSO = 96
+C initialize //
+ DO 30 I=1,100
+ IDEB(I) = 0
+ 30 CONTINUE
+C initialize /PROCES/
+ DO 35 I=1,11
+ IPRON(I,1) = 1
+ 35 CONTINUE
+
+C DPMJET default: no elastic scattering
+ IPRON(2,1) = 0
+
+ DO 36 K=2,4
+ DO 37 I=2,11
+ IPRON(I,K) = 0
+ 37 CONTINUE
+ IPRON(1,K) = 1
+ IPRON(8,K) = 1
+ 36 CONTINUE
+C initialize /POSVDM/
+ TWOPIM = 0.28D0
+ RMIN(1) = 0.285D0
+ RMIN(2) = 0.45D0
+ RMIN(3) = 1.D0
+ RMIN(4) = TWOPIM
+ VMAS(1) = 0.770D0
+ VMAS(2) = 0.787D0
+ VMAS(3) = 1.02D0
+ VMAS(4) = TWOPIM
+ GAMM(1) = 0.155D0
+ GAMM(2) = 0.01D0
+ GAMM(3) = 0.0045D0
+ GAMM(4) = 1.D0
+ RMAX(1) = VMAS(1)+TWOPIM
+ RMAX(2) = VMAS(2)+TWOPIM
+ RMAX(3) = VMAS(3)+TWOPIM
+ RMAX(4) = VMAS(1)+TWOPIM
+ VMSL(1) = 11.D0
+ VMSL(2) = 10.D0
+ VMSL(3) = 6.D0
+ VMSL(4) = 4.D0
+ VMFA(1) = 0.0033D0
+ VMFA(2) = 0.00036D0
+ VMFA(3) = 0.0002D0
+ VMFA(4) = 0.0002D0
+C initialize /PODGL1/
+ Q2MISR(1) = PARMDL(36)**2
+ Q2MISR(2) = PARMDL(36)**2
+ PMISR(1) = 1.D0
+ PMISR(2) = 1.D0
+ ZMISR(1) = 0.001D0
+ ZMISR(2) = 0.001D0
+ AL2ISR(1) = 0.046D0
+ AL2ISR(2) = 0.046D0
+ NFSISR = 4
+C initialize /POPISR/
+ DO 40 I=1,50
+ IPOISR(1,2,I) = 0
+ IPOISR(2,2,I) = 0
+ 40 CONTINUE
+C initialize /POHPRO/
+ PROC(0) = 'sum over processes'
+ PROC(1) = 'G +G --> G +G '
+ PROC(2) = 'Q +QB --> G +G '
+ PROC(3) = 'G +Q --> G +Q '
+ PROC(4) = 'G +G --> Q +QB '
+ PROC(5) = 'Q +QB --> Q +QB '
+ PROC(6) = 'Q +QB --> QP +QBP'
+ PROC(7) = 'Q +Q --> Q +Q '
+ PROC(8) = 'Q +QP --> Q +QP '
+ PROC(9) = 'resolved processes'
+ PROC(10) = 'gam+Q --> G +Q '
+ PROC(11) = 'gam+G --> Q +QB '
+ PROC(12) = 'Q +gam--> G +Q '
+ PROC(13) = 'G +gam--> Q +QB '
+ PROC(14) = 'gam+gam--> Q +QB '
+ PROC(15) = 'direct processes '
+ PROC(16) = 'gam+gam--> l+ +l- '
+
+C initialize /POHRCS/
+ do M=1,Max_pro_2
+ HWgx(M) = 0.D0
+ HSig(M) = 0.D0
+ Hdpt(M) = 0.D0
+ enddo
+ DO I=0,4
+ DO M=-1,Max_pro_2
+C switch all hard subprocesses on
+ MH_pro_on(M,I) = 1
+C reset all counters
+ MH_tried(M,I) = 0
+ MH_acc_1(M,I) = 0
+ MH_acc_2(M,I) = 0
+ ENDDO
+ MH_pro_on(16,I) = 0
+ ENDDO
+
+C initialize /POHTAB/
+ do I=0,4
+ IH_Ecm_up(I) = 0
+ IH_Q2a_up(I) = 0
+ IH_Q2b_up(I) = 0
+ HEcm_tab(1,I) = 0.D0
+ enddo
+ HEcm_last = 0.D0
+ IHa_last = 0.D0
+ IHb_last = 0.D0
+
+C initialize /POFSRC/
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+C initialize /LEPCUT/
+ ECMIN = 5.D0
+ ECMAX = 1.D+30
+ EEMIN1 = 1.D0
+ EEMIN2 = 1.D0
+ YMAX1 = -1.D0
+ YMAX2 = -1.D0
+ THMIN1 = 0.D0
+ THMAX1 = PI
+ THMIN2 = 0.D0
+ THMAX2 = PI
+ ITAG1 = 1
+ ITAG2 = 1
+C initialize /POWGHT/
+ DO 70 I=1,20
+ HSWCUT(I) = 0.D0
+ ISWCUT(I) = 0
+ 70 CONTINUE
+ EVWGHT(1) = 1.D0
+ IVWGHT(1) = 0
+ SIGGEN(1) = 0.D0
+ SIGGEN(2) = 0.D0
+ SIGGEN(3) = 0.D0
+ SIGGEN(4) = 0.D0
+
+ END
+
+*$ CREATE PHO_PARDAT.FOR
+*COPY PHO_PARDAT
+CDECK ID>, PHO_PARDAT
+ SUBROUTINE PHO_PARDAT
+C***********************************************************************
+C
+C particle data (based on 1996 PDG naming scheme and data tables)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+C external functions
+
+ integer ipho_pdg2id
+ double precision pho_pmass
+
+C local variables for storing data tables
+
+ integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
+ & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
+
+ dimension number(300),ich3(300),iba3(300),iq_linear(900),
+ & idec_linear(900),isec_linear(900),id_psm_linear(36),
+ & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
+
+ double precision xmass,gamma,wg_chan
+ dimension xmass(300),gamma(300),wg_chan(300)
+
+ character*12 name
+ dimension name(300)
+
+ integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
+ double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
+
+ integer itmp
+
+ DATA i_tab_max /260/
+
+ DATA (number(K),K= 1, 171) /
+ & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
+ & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
+ & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
+ & 110, 990, 21, 22, 24, 23, 11, 13, 15,
+ & 12, 14, 16, 211, 111, 221, 113, 213, 223,
+ & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
+ & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
+ & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
+ & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
+ & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
+ & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
+ & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
+ & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
+ & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
+ & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
+ & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
+ & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
+ & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
+ & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
+ DATA (number(K),K= 172, 260) /
+ & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
+ & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
+ & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
+ & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
+ & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
+ & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
+ & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
+ & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
+ & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
+ & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
+ DATA (name(K),K= 1, 76) /
+ &'d ','u ','s ','c ',
+ &'b ','t ','(dd)_1 ','(ud)_0 ',
+ &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
+ &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
+ &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
+ &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
+ &'string ','mod. string ','coll. string','reggeon ',
+ &'pomeron ','gluon ','gamma ','W ',
+ &'Z ','e ','mu ','tau ',
+ &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
+ &'pi ','eta ','rho(770) ','rho(770) ',
+ &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
+ &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
+ &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
+ &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
+ &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
+ &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
+ &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
+ &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
+ DATA (name(K),K= 77, 152) /
+ &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
+ &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
+ &'K ','K(S) ','K(L) ','K*(892) ',
+ &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
+ &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
+ &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
+ &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
+ &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
+ &'K(4)*(2045) ','D ','D ','D*(2007) ',
+ &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
+ &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
+ &'B ','B* ','B* ','B(s) ',
+ &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
+ &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
+ &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
+ &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
+ &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
+ &'Ups(10860) ','Ups(11020) ','p ','n ',
+ &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
+ DATA (name(K),K= 153, 228) /
+ &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
+ &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
+ &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
+ &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
+ &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
+ &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
+ &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
+ &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
+ &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
+ &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
+ &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
+ &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
+ &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
+ &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
+ &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
+ &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
+ &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
+ &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
+ &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
+ DATA (name(K),K= 229, 260) /
+ &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
+ &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
+ &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
+ &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
+ &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
+ &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
+ &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
+ &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
+ DATA (ich3(K),K= 1, 260) /
+ &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
+ & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
+ & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
+ &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
+ & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
+ & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
+ & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
+ DATA (iba3(K),K= 1, 260) /
+ &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,
+ &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,
+ &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,
+ &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,
+ &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,
+ &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,
+ &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,
+ &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/
+ DATA (iq_linear(K),K= 1, 418) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
+ & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
+ & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
+ & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
+ &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
+ & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
+ & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
+ &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
+ & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
+ & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
+ &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
+ & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
+ & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
+ &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
+ & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
+ & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
+ DATA (iq_linear(K),K= 419, 780) /
+ &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
+ & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
+ & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
+ & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
+ & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
+ & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
+ & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
+ & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
+ & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
+ & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
+ & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
+ & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
+ & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
+ & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
+ & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
+ & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
+ & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
+ DATA (xmass(K),K= 1, 114) /
+ &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
+ &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
+ &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
+ &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
+ &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
+ &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
+ &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
+ &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
+ &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
+ &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
+ &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
+ &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
+ &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
+ &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
+ &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
+ &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
+ DATA (xmass(K),K= 115, 228) /
+ &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
+ &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
+ &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
+ &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
+ &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
+ &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
+ &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
+ &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
+ &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
+ &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
+ &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
+ &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
+ &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
+ &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
+ &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
+ &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
+ &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
+ &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
+ &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
+ DATA (xmass(K),K= 229, 260) /
+ &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
+ &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
+ &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
+ &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
+ &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
+ &2.7040E+00,5.6240E+00/
+ DATA (gamma(K),K= 1, 114) /
+ &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
+ &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
+ &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
+ &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
+ &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
+ &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
+ &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
+ &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
+ &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
+ &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
+ &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
+ &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
+ &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
+ &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
+ &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
+ &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
+ DATA (gamma(K),K= 115, 228) /
+ &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
+ &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
+ &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
+ &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
+ &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
+ &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
+ &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
+ &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
+ &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
+ &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
+ &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
+ &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
+ &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
+ &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
+ &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
+ &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
+ DATA (gamma(K),K= 229, 260) /
+ &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
+ &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
+ &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
+ &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
+ &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
+ &1.0200E-11,5.3100E-13/
+ DATA (idec_linear(K),K= 1, 304) /
+ & 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, 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, 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, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
+ & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 25, 29, 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, 0, 0, 0, 0, 0, 0, 1, 30, 32,
+ & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
+ & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
+ & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
+ & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (idec_linear(K),K= 305, 608) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 2, 77, 78, 2, 79, 82, 1, 83, 84,
+ & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
+ & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 99,101, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
+ &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,137,144, 1,145,152, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
+ &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
+ &163,169, 1,170,176, 1,177,180, 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, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (idec_linear(K),K= 609, 780) /
+ & 0, 0, 0, 0, 3,181,182, 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, 0, 0, 0, 3,183,184, 3,185,
+ &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 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, 1,195,203, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,204,216, 0, 0, 0, 3,217,217, 3,
+ &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
+ &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
+ & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
+ DATA (isec_linear(K),K= 1, 152) /
+ & 11, 12, -12, 13, -14, 16, 11, -12,
+ & 16, -213, 16, 0, -211, 16, 0, -323,
+ & 16, 0, -13, 12, 0, 22, 22, 0,
+ & 22, -11, 11, 22, 22, 0, 111, 22,
+ & 22, 111, 111, 111, 211, -211, 111, 211,
+ & -211, 22, 211, -211, 0, 111, 111, 0,
+ & 211, 111, 0, 211, -211, 111, 211, -211,
+ & 0, 111, 22, 0, 221, 211, -211, 221,
+ & 111, 111, 211, -211, 22, 22, 22, 0,
+ & 321, -321, 0, 130, 310, 0, 113, 111,
+ & 0, 211, -211, 111, 221, 22, 0, 113,
+ & 111, 0, -213, 211, 0, 213, -211, 0,
+ & 211, -211, 0, 111, 111, 0, 113, 111,
+ & 0, -213, 211, 0, 213, -211, 0, 311,
+ & -313, 0, -311, 313, 0, 113, 211, -211,
+ & -13, 12, 0, 211, 111, 0, 211, 211,
+ & -211, 211, 111, 111, -13, 111, 12, -11,
+ & 111, 12, 211, -211, 0, 111, 111, 0,
+ & 111, 111, 111, 211, -211, 111, 211, 13/
+ DATA (isec_linear(K),K= 153, 304) /
+ & 12, 211, 11, 12, 321, 111, 0, 311,
+ & 211, 0, 311, 111, 0, 321, -211, 0,
+ & 311, 111, 0, 321, -211, 0, 321, 111,
+ & 0, 311, 211, 0, 311, 111, 0, 321,
+ & -211, 0, 313, 111, 0, 323, -211, 0,
+ & 311, 113, 0, 321, -213, 0, 311, 223,
+ & 0, 311, 221, 0, 321, 111, 0, 311,
+ & 211, 0, 323, 111, 0, 313, 211, 0,
+ & 321, 113, 0, 311, 213, 0, 321, 223,
+ & 0, 321, 221, 0, -321, 211, 211, -311,
+ & 211, 0, -321, 211, 0, -321, 211, 111,
+ & 311, 211, -211, 311, 111, 0, 421, 111,
+ & 0, 421, 22, 0, 421, 211, 0, 411,
+ & 111, 0, 411, 22, 0, 221, 211, 0,
+ & 321, -321, 321, 321, -311, 0, 431, 22,
+ & 0, 431, 22, 0, 111, 111, 0, 211,
+ & -211, 0, 22, 22, 0, -11, 11, 0,
+ & -13, 13, 0, 211, -211, 111, 443, 211,
+ & -211, 443, 111, 111, 443, 221, 0, 2212/
+ DATA (isec_linear(K),K= 305, 456) /
+ & 11, 12, 2112, 111, 0, 2212, -211, 0,
+ & 2112, 111, 111, 2112, 211, -211, 1114, 211,
+ & 0, 2114, 111, 0, 2214, -211, 0, 2112,
+ & 113, 0, 2212, -213, 0, 2112, 221, 0,
+ & 2212, 111, 0, 2112, 211, 0, 2212, 111,
+ & 111, 2212, 211, -211, 2224, -211, 0, 2214,
+ & 111, 0, 2114, 211, 0, 2212, 113, 0,
+ & 2112, 213, 0, 2212, 221, 0, 2212, -211,
+ & 0, 2112, 111, 0, 2214, -211, 0, 2114,
+ & 111, 0, 1114, 211, 0, 2212, -213, 0,
+ & 2112, 113, 0, 2212, 111, 0, 2112, 211,
+ & 0, 2224, -211, 0, 2214, 111, 0, 2114,
+ & 211, 0, 2212, 113, 0, 2112, 213, 0,
+ & 2212, -211, 0, 2112, 111, 0, 2212, -213,
+ & 0, 2112, 113, 0, 3122, 311, 0, 3212,
+ & 311, 0, 3112, 321, 0, 2112, 221, 0,
+ & 2212, 111, 0, 2112, 211, 0, 2212, 113,
+ & 0, 2112, 213, 0, 3122, 321, 0, 3222,
+ & 311, 0, 3212, 321, 0, 2212, 221, 0/
+ DATA (isec_linear(K),K= 457, 608) /
+ & 2112, -211, 0, 2212, -211, 0, 2112, 111,
+ & 0, 2212, 111, 0, 2112, 211, 0, 2212,
+ & 211, 0, 2112, -211, 0, 2114, -211, 0,
+ & 1114, 111, 0, 2112, -213, 0, 2212, -211,
+ & 0, 2112, 111, 0, 2214, -211, 0, 2114,
+ & 111, 0, 1114, 211, 0, 2212, -213, 0,
+ & 2112, 113, 0, 2212, 111, 0, 2112, 211,
+ & 0, 2224, -211, 0, 2214, 111, 0, 2114,
+ & 211, 0, 2212, 113, 0, 2112, 213, 0,
+ & 2212, 211, 0, 2224, 111, 0, 2214, 211,
+ & 0, 2212, 213, 0, 2212, -211, 0, 2112,
+ & 111, 0, 2212, 111, 0, 2112, 211, 0,
+ & 3122, 22, 0, 2112, -211, 0, 3122, 211,
+ & 0, 3212, 211, 0, 3222, 111, 0, 3122,
+ & 111, 0, 3222, -211, 0, 3112, 211, 0,
+ & 3122, -211, 0, 3212, -211, 0, 2112, -311,
+ & 0, 2212, -321, 0, 3222, -211, 0, 3212,
+ & 111, 0, 3112, 211, 0, 3122, 221, 0,
+ & 3224, -211, 0, 3114, 211, 0, 3214, 111/
+ DATA (isec_linear(K),K= 609, 760) /
+ & 0, 2112, -311, 0, 2212, -321, 0, 3122,
+ & 111, 0, 3122, 223, 0, 3122, 113, 0,
+ & 3222, -213, 0, 3112, 213, 0, 3212, 113,
+ & 0, 3122, 221, 0, 3212, 221, 0, 3222,
+ & -211, 0, 3112, 211, 0, 3212, 111, 0,
+ & 3122, 111, 0, 3122, -211, 0, 3322, 111,
+ & 0, 3312, 211, 0, 3322, -211, 0, 3312,
+ & 111, 0, 3322, -211, 0, 3312, 111, 0,
+ & 3122, -321, 0, 3222, 221, 0, 3222, 331,
+ & 0, 2212, -311, 0, 3322, 321, 0, 3224,
+ & 221, 0, 2214, 331, 0, 2224, -321, 0,
+ & 3122, 213, 0, 3212, 213, 0, 3222, 113,
+ & 0, 3222, 223, 0, 2212, -313, 0, 2214,
+ & -313, 0, 2224, -323, 0, 4122, 211, 0,
+ & 4122, 111, 0, 4122, -211, 0, 3222, -311,
+ & 0, 3322, 211, 0, 3222, -313, 0, 3322,
+ & 213, 0, 3212, -313, 0, 3222, -323, 0,
+ & 3322, 223, 0, 3312, 213, 0, 3214, -313,
+ & 0, 3322, -311, 0, 3322, 313, 0, 3334/
+ DATA (isec_linear(K),K= 761, 765) /
+ & 213, 0, 3334, 211, 0/
+ DATA (wg_chan(K),K= 1, 114) /
+ &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
+ &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
+ &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
+ &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
+ &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
+ &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
+ &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
+ &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
+ &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
+ &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
+ &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
+ &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
+ &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
+ &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
+ &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
+ &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
+ &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
+ &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
+ &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
+ DATA (wg_chan(K),K= 115, 228) /
+ &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
+ &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
+ &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
+ &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
+ &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
+ &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
+ &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
+ &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
+ &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
+ &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
+ &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
+ &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
+ &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
+ &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
+ &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
+ &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
+ &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
+ &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
+ &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
+ DATA (wg_chan(K),K= 229, 255) /
+ &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
+ &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
+ &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
+ &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
+ &2.0000E-01,3.6000E-01,7.0000E-02/
+ DATA (id_psm_linear(K),K= 1, 36) /
+ & 111, 211, -311, 411, 0, 0, -211, 111,
+ & -321, 421, 0, 0, 311, 321, 221, 431,
+ & 0, 0, -411, -421, -431, 441, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0/
+ DATA (id_vem_linear(K),K= 1, 36) /
+ & 113, 213, -313, 413, 0, 0, -213, 113,
+ & -323, 423, 0, 0, 313, 323, 333, 433,
+ & 0, 0, -413, -423, -433, 20443, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0/
+ DATA (id_b8_linear(K),K= 1, 171) /
+ & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
+ & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
+ & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
+ & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
+ & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
+ & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
+ & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
+ & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
+ & 4412, 4422, 4432, 4444, 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, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b8_linear(K),K= 172, 216) /
+ & 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, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b10_linear(K),K= 1, 171) /
+ & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
+ & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
+ & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
+ & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
+ & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
+ & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
+ & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
+ & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
+ & 4414, 4424, 4434, 4444, 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, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b10_linear(K),K= 172, 216) /
+ & 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, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+
+ ID_pdg_max = i_tab_max
+
+C copy from local to global variables
+ do i=1,i_tab_max
+ ID_pdg_list(i) = number(i)
+ name_list(i) = name(i)
+ xm_list(i) = xmass(i)
+ gam_list(i) = gamma(i)
+ ich3_list(i) = ich3(i)
+ iba3_list(i) = iba3(i)
+ do j=1,3
+ iq_list(j,i) = iq_linear(3*(i-1)+j)
+ idec_list(j,i) = idec_linear(3*(i-1)+j)
+ enddo
+ enddo
+
+C initialize hash table
+ call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
+
+ itmp = IDEB(71)
+ IDEB(71) = -1
+
+C quark index table for mesons
+ do i=1,6
+ do j=1,6
+ id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
+ id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
+ enddo
+ enddo
+
+C quark index table for baryons
+ do i=1,6
+ do j=1,6
+ do k=1,6
+ id_b8_list(i,j,k) =
+ & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
+ id_b10_list(i,j,k) =
+ & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
+ enddo
+ enddo
+ enddo
+
+ IDEB(71) = itmp
+
+C copy secondary particles
+C (translate PDG-ID to CPC and sort according to CPC)
+ ichan = 0
+ do i=1,i_tab_max
+ if(idec_list(1,i).ne.0) then
+ do j=idec_list(2,i),idec_list(3,i)
+ ichan = ichan+1
+ wg_sec_list(ichan) = wg_chan(j)
+ do k=1,3
+ if(isec_linear(3*(j-1)+k).ne.0) then
+ isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
+ else
+ isec_list(k,ichan) = 0
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+C add two-pion background (low-mass photon dissociation)
+ i = ipho_pdg2id(92)
+ ichan = ichan+1
+ idec_list(1,i) = 1
+ idec_list(2,i) = ichan
+ idec_list(3,i) = ichan
+ wg_sec_list(ichan) = 1.D0
+ isec_list(1,ichan) = ipho_pdg2id(211)
+ isec_list(2,ichan) = ipho_pdg2id(-211)
+ isec_list(3,ichan) = 0
+
+C min. mass limits for strings: q-qbar
+ do i=1,6
+ do j=1,6
+ AM2P = 1000.D0
+ AM2V = 1000.D0
+ do k=1,3
+C pseudo-scalar mesons
+ i1 = iabs(id_psm_list(i,k))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+ i2 = iabs(id_psm_list(k,j))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(k,3)+pho_pmass(j,3)
+ endif
+ AM2P = MIN(AM2P,AM1+AM2)
+C vector mesons
+ i1 = iabs(id_vem_list(i,k))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+ i2 = iabs(id_vem_list(k,j))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(k,3)+pho_pmass(j,3)
+ endif
+ AM2V = MIN(AM2V,AM1+AM2)
+ enddo
+ xm_psm2_list(i,j) = AM2P
+ xm_vem2_list(i,j) = AM2V
+ enddo
+ enddo
+
+C min. mass limits for strings: qq-q
+ do i=1,6
+ do j=1,6
+ do k=1,6
+ AM82 = 1000.D0
+ AM102 = 1000.D0
+ do l=1,3
+C pseudo-scalar meson
+ i1 = iabs(id_psm_list(k,l))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+C vector meson
+ i2 = iabs(id_vem_list(k,l))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+C octet baryon
+ AMM = min(AM1,AM2)
+ K8 = id_b8_list(i,j,l)
+ if(K8.ne.0) then
+ AM1 = xm_list(K8)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ AM82 = MIN(AM82, AM1 + AMM)
+C decuplet baryon
+ K10 = id_b10_list(i,j,l)
+ if(K10.ne.0) then
+ AM2 = xm_list(K10)
+ else
+ AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ AM102 = MIN(AM102, AM2 + AMM)
+ enddo
+ xm_b82_list(i,j,k) = AM82
+ xm_b102_list(i,j,k) = AM102
+ enddo
+ enddo
+ enddo
+
+C min. mass limits for strings: qq-qbarqbar
+ do i=1,6
+ do j=1,6
+ do ii=1,6
+ do jj=1,6
+ AM82 = 1000.D0
+ AM102 = 1000.D0
+ do l=1,3
+C octet baryons
+ K8 = id_b8_list(i,j,l)
+ if(K8.ne.0) then
+ AM1 = xm_list(K8)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ L8 = id_b8_list(ii,jj,l)
+ if(L8.ne.0) then
+ AM2 = xm_list(L8)
+ else
+ AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
+ endif
+ AM82 = MIN(AM82, AM1+AM2)
+C decuplet baryons
+ K10 = id_b10_list(i,j,l)
+ if(K10.ne.0) then
+ AM1 = xm_list(K10)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ L10 = id_b10_list(ii,jj,l)
+ if(L10.ne.0) then
+ AM2 = xm_list(L10)
+ else
+ AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
+ endif
+ AM102 = MIN(AM102, AM1+AM2)
+ enddo
+ xm_bb82_list(i,j,ii,jj) = AM82
+ xm_bb102_list(i,j,ii,jj) = AM102
+ enddo
+ enddo
+ enddo
+ enddo
+
+ END
+
+*$ CREATE PHO_PRESEL.FOR
+*COPY PHO_PRESEL
+CDECK ID>, PHO_PRESEL
+ SUBROUTINE PHO_PRESEL(MODE,IREJ)
+C**********************************************************************
+C
+C user specific function to pre-select events during generation
+C
+C input: MODE 5 electron and photon kinematics
+C 10 process and number of cut Pomerons
+C 15 partons without construction of strings
+C 20 partons assigned to strings
+C 25 after fragmentation, complete final state
+C
+C output: IREJ 0 event accepted
+C 50 event rejected
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ IREJ = 0
+
+* XBJ = GQ2(2)/(GGECM**2+GQ2(2))
+* IF(XBJ.LT.0.002D0) IREJ = 1
+
+ END
+
+*$ CREATE PHO_FIXCOL.FOR
+*COPY PHO_FIXCOL
+CDECK ID>, PHO_FIXCOL
+ SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+C**********************************************************************
+C
+C interface to call PHOJET (fixed energy run) with
+C collider kinematics
+C
+C equivalen photon approximation to get photon flux
+C
+C input: NEV number of events to generate
+C THETA azimuthal angle (micro radians)
+C PHI beam crossing angle
+C (with respect to x, in degrees)
+C E1 energy of particle 1 (+z direction, GeV)
+C E2 energy of particle 2 (-z direction, GeV)
+C
+C note: particle types have to be specified before
+C with PHO_SETPAR
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+C remnant initialization (only needed for DPMJET)
+ ISAVP1 = IFPAP(1)
+ ISAVB1 = IFPAB(1)
+ IF(IFPAP(1).EQ.81) THEN
+ IFPAP(1) = IDEQP(1)
+ IFPAB(1) = IDEQB(1)
+ ENDIF
+ ISAVP2 = IFPAP(2)
+ ISAVB2 = IFPAB(2)
+ IF(IFPAP(2).EQ.82) THEN
+ IFPAP(2) = IDEQP(2)
+ IFPAB(2) = IDEQB(2)
+ ENDIF
+ PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
+ PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
+ PP1 = SQRT(E1**2-PMASS1**2)
+ PP2 = SQRT(E2**2-PMASS2**2)
+C beam crossing angle
+ TH = 1.D-6*THETA/2.D0
+ PH = PHI*BOG
+ P1(1) = PP1*SIN(TH)*COS(PH)
+ P1(2) = PP1*SIN(TH)*SIN(PH)
+ P1(3) = PP1*COS(TH)
+ P1(4) = E1
+ P2(1) = PP2*SIN(TH)*COS(PH)
+ P2(2) = PP2*SIN(TH)*SIN(PH)
+ P2(3) = -PP2*COS(TH)
+ P2(4) = E2
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ IFPAP(1) = ISAVP1
+ IFPAB(1) = ISAVB1
+ IFPAP(2) = ISAVP2
+ IFPAB(2) = ISAVB2
+ ITRY = 0
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C test of DPMJET interface (default is IPAMDL(13)=0)
+ if(IPAMDL(13).gt.0) then
+ MODE = IPAMDL(13)
+ IPAMDL(13) = 0
+ else
+ MODE = 1
+ endif
+C main generation loop
+ DO 50 I=1,NEV
+ 55 CONTINUE
+ ITRY = ITRY+1
+ CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 55
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 50 CONTINUE
+
+ IF(NEV.GT.0) THEN
+ SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',SIGMAX,' mb *****',
+ & '========================================================='
+ CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
+ CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_LHIST(-2,SIGMAX)
+ ELSE
+ WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
+ ENDIF
+
+ END
+
+*$ CREATE PHO_FIXLAB.FOR
+*COPY PHO_FIXLAB
+CDECK ID>, PHO_FIXLAB
+ SUBROUTINE PHO_FIXLAB(PLAB,NEV)
+C**********************************************************************
+C
+C interface to call PHOJET (fixed energy run) with
+C LAB kinematics (second particle as target)
+C
+C equivalent photon approximation to get photon flux
+C
+C input: NEV number of events to generate
+C PLAB LAB momentum of particle 1
+C
+C note: particle types have to be specified before
+C with PHO_SETPAR
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+C remnant initialization (only needed for DPMJET)
+ SPCM = PLAB
+ ISAVP1 = IFPAP(1)
+ ISAVB1 = IFPAB(1)
+ IF(IFPAP(1).EQ.81) THEN
+ IFPAP(1) = IDEQP(1)
+ IFPAB(1) = IDEQB(1)
+ ENDIF
+ ISAVP2 = IFPAP(2)
+ ISAVB2 = IFPAB(2)
+ IF(IFPAP(2).EQ.82) THEN
+ IFPAP(2) = IDEQP(2)
+ IFPAB(2) = IDEQB(2)
+ ENDIF
+C get momenta in LAB system
+ PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
+ PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
+ IF(PMASS2.LT.0.1D0) THEN
+ WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
+ & 'no LAB system possible',IFPAB(1),IFPAB(2)
+ ELSE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = PLAB
+ P1(4) = SQRT(PMASS1+PLAB**2)
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = 0.D0
+ P2(4) = SQRT(PMASS2)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ IFPAP(1) = ISAVP1
+ IFPAB(1) = ISAVB1
+ IFPAP(2) = ISAVP2
+ IFPAB(2) = ISAVB2
+ ITRY = 0
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C event generation loop
+ DO 40 I=1,NEV
+ 45 CONTINUE
+ ITRY = ITRY+1
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 45
+ CALL PHO_LHIST(1,HSWGHT(0))
+
+ CALL PHO_PHIST(10,HSWGHT(0))
+
+ 40 CONTINUE
+ IF(NEV.GT.0) THEN
+ SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',SIGMAX,' mb *****',
+ & '========================================================='
+ CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
+ CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_LHIST(-2,SIGMAX)
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_FIXLAB: no events simulated',NEV
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GPHERA.FOR
+*COPY PHO_GPHERA
+CDECK ID>, PHO_GPHERA
+ SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) with
+C HERA kinematics, photon as particle 2
+C
+C equivalent photon approximation to get photon flux
+C
+C input: NEVENT number of events to generate
+C EE1 proton energy (LAB system)
+C EE2 electron energy (LAB system)
+C from /POFCUT/:
+C YMIN2 lower limit of Y
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y
+C Q2MIN2 lower limit of photon virtuality
+C Q2MAX2 upper limit of photon virtuality
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
+C assign particle momenta according to HERA kinematics
+C proton data
+ PROM = PHO_PMASS(2212,1)
+ PROM2 = PROM**2
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+C electron data
+ ELEM = 0.512D-03
+ ELEM2 = ELEM**2
+ AMSRC(2) = ELEM
+ IDPSRC(2) = 11
+ IDBSRC(2) = ipho_pdg2id(11)
+C
+ Q2MIN = Q2MIN2
+ Q2MAX = Q2MAX2
+C
+ XIMAX = LOG(YMAX2)
+ XIMIN = LOG(YMIN2)
+ XIDEL = XIMAX-XIMIN
+C
+ IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
+ & WRITE(LO,'(/1X,A,1P2E11.4)')
+ & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
+ & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
+C
+ Max_tab = 50
+ DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
+ FLUXT = 0.D0
+ FLUXL = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
+ DO 100 I=1,Max_tab
+ Y = EXP(XIMIN+DELLY*DBLE(I-1))
+ Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
+ FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+ & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
+ FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
+ FLUXT = FLUXT + Y*FFT
+ FLUXL = FLUXL + Y*FFL
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
+ 100 CONTINUE
+ FLUXT = FLUXT*DELLY
+ FLUXL = FLUXL*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
+ & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
+C
+ AY = 0.D0
+ AY2 = 0.D0
+ YY = YMIN2
+ Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
+ WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
+ & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
+ IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
+C
+C initialization of PHOJET at upper energy limit
+C proton momentum
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EE1**2-PROM2+DEPS)
+ P1(4) = EE1
+C photon momentum
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+C sum of both photon polarizations
+ IGHEL(2) = -1
+C
+ CALL PHO_SETPAR(1,2212,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ ECMIN2 = ECMIN**2
+ ECMAX2 = ECMAX**2
+ AY = 0.D0
+ AY2 = 0.D0
+ Q22MIN = 1.D30
+ Q22AVE = 0.D0
+ Q22AV2 = 0.D0
+ Q22MAX = 0.D0
+ AN2MIN = 1.D30
+ AN2MAX = 0.D0
+ YY2MIN = 1.D30
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+C sample y
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
+ IF(ISWMDL(10).GE.2) THEN
+ YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
+ ELSE
+ YEFF = 1.D0+(1.D0-YY)**2
+ ENDIF
+ Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
+ Q2LOG = LOG(Q2MAX/Q2LOW)
+ WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ 185 CONTINUE
+ Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
+ WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
+ ELSE
+ Q2 = Q2LOW
+ ENDIF
+C
+
+C incoming electron
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron
+ YQ2 = SQRT((1.D0-YY)*Q2)
+ Q2E = Q2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-YY)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C set /POFSRC/
+ GYY(2) = YY
+ GQ2(2) = Q2
+C polar angle
+ PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
+C electron tagger
+ IF(PFIN(4,2).GT.EEMIN2) THEN
+ IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
+ ENDIF
+C azimuthal angle
+ PFPHI(2) = ATAN2(COF,SIF)
+C photon momentum
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C proton momentum
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EE1**2-PROM2)
+ P1(4) = EE1
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
+ GGECM = SQRT(GGECM)
+C
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2)
+C photon helicity
+ IF(ISWMDL(10).GE.2) THEN
+ WGH = YEFF-2.D0*ELEM2*YY**2/Q2
+ WGHL = 2.D0*(1-YY)
+ IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
+ IGHEL(2) = 1
+ ELSE
+ IGHEL(2) = 0
+ ENDIF
+ ELSE
+ IGHEL(2) = -1
+ ENDIF
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY = AY+YY
+ AY2 = AY2+YY*YY
+ YY2MIN = MIN(YY2MIN,YY)
+ YY2MAX = MAX(YY2MAX,YY)
+ Q22MIN = MIN(Q22MIN,Q2)
+ Q22MAX = MAX(Q22MAX,Q2)
+ Q22AVE = Q22AVE+Q2
+ Q22AV2 = Q22AV2+Q2*Q2
+ AN2MIN = MIN(AN2MIN,PFTHE(2))
+ AN2MAX = MAX(AN2MAX,PFTHE(2))
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
+ WGY = WGY*LOG(YMAX2/YMIN2)
+ AY = AY/DBLE(NITER)
+ AY2 = AY2/DBLE(NITER)
+ DAY = SQRT((AY2-AY**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
+ & Q22MIN,Q22MAX
+ WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
+ & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGEPEM.FOR
+*COPY PHO_GGEPEM
+CDECK ID>, PHO_GGEPEM
+ SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions on e+e- collider
+C
+C fully differential equivalent (improved) photon approximation
+C to get photon flux
+C
+C input: EE1 LAB system energy of electron/positron 1
+C EE2 LAB system energy of electron/positron 2
+C NEVENT >0 number of events to generate
+C -1 initialization
+C -2 final call (cross section calculation)
+C from /LEPCUT/:
+C YMIN1 lower limit of Y1
+C (energy fraction taken by photon from electron)
+C YMAX1 upper limit of Y1
+C Q2MIN1 lower limit of photon virtuality
+C Q2MAX1 upper limit of photon virtuality
+C THMIN1 lower limit of scattered electron
+C THMAX1 upper limit of scattered electron
+C YMIN2 lower limit of Y2
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y2
+C Q2MIN2 lower limit of photon virtuality
+C Q2MAX2 upper limit of photon virtuality
+C THMIN2 lower limit of scattered electron
+C THMAX2 upper limit of scattered electron
+C
+C output: after final call with NEVENT=-2
+C EE1 e+ e- cross section (mb)
+C EE2 gamma-gamma cross section (mb)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION EE1,EE2
+ INTEGER NEVENT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+C external functions
+ DOUBLE PRECISION DT_RNDM
+
+C local variables
+ DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
+ & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
+ & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
+ & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
+ & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
+ & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
+ & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
+ & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
+ & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
+
+ INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
+ & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
+
+ DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
+ integer ipho_pdg2id
+
+C initialization of event generation
+
+ if(NEVENT.eq.-1) then
+
+ DO 10 I=1,4
+ IHETRY(I) = 0
+ IHEAC1(I) = 0
+ IHEAC2(I) = 0
+ 10 CONTINUE
+
+ WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
+
+C electron data
+ ELEM = 0.512D-03
+ ELEM2 = ELEM**2
+ AMSRC(1) = ELEM
+ AMSRC(2) = ELEM
+C lepton numbers
+ IDPSRC(1) = 11
+ IDPSRC(2) = -11
+ IDBSRC(1) = ipho_pdg2id(11)
+ IDBSRC(2) = ipho_pdg2id(-11)
+
+C check/update kinematic limitations
+
+ Ymi = min(Ymax1,1.D0-ELEM/EE1)
+ if(Ymi.lt.Ymax1) then
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
+ Ymax1 = YMI
+ endif
+ Ymi = min(Ymax2,1.D0-ELEM/EE2)
+ if(Ymi.lt.Ymax2) then
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
+ Ymax2 = YMI
+ endif
+
+ YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+
+C store COS of angular tagging range
+ THMIC1 = COS(MAX(0.D0,THMIN1))
+ THMAC1 = COS(MIN(THMAX1,PI))
+ THMIC2 = COS(MAX(0.D0,THMIN2))
+ THMAC2 = COS(MIN(THMAX2,PI))
+
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+
+C debug: integrated photon flux
+
+ if(IDEB(30).ge.1) then
+ Max_tab = 50
+ FLUXT = 0.D0
+ FLUXL = 0.D0
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
+ & 'table of photon flux (trans/long side 1)',Max_tab
+ do I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ if((1.D0-Y1).gt.1.D-8) then
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
+ else
+ Q2low1 = 2.D0*Q2max1
+ endif
+ if(Q2low1.lt.Q2max1) then
+ FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
+ FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
+ else
+ FFT = 0.D0
+ FFL = 0.D0
+ endif
+ FLUXT = FLUXT + Y1*FFL
+ FLUXL = FLUXL + Y1*FFT
+ IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
+ enddo
+ FLUXT = FLUXT*DELLY
+ FLUXL = FLUXL*DELLY
+ WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
+ & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
+ endif
+
+C maximum weight
+
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ IF(ISWMDL(10).GE.2) THEN
+C long. and transversely polarized photons
+ WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ ELSE
+C transversely polarized photons only
+ WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ ENDIF
+
+C initialize gamma-gamma event generator
+
+C photon 1
+ EGAM = YMAX1*EE1
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EGAM**2-Q2LOW1)
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EGAM**2-Q2LOW2)
+ P2(4) = EGAM
+C sum of helicities
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+
+C set min. energy for interpolation tables
+ parmdl(19) = min(parmdl(19),ecmin)
+
+C initialize event gneration
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events, flux calculation
+
+ ECMIN2 = ECMIN**2
+ ECMAX2 = ECMAX**2
+ ECFRAC = ECMIN2/(4.D0*EE1*EE2)
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ AN1MIN = 1.D30
+ AN2MIN = 1.D30
+ AN1MAX = 0.D0
+ AN2MAX = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = 0
+ ITRY_low = 0
+ ITRY_high = 0
+ ITRW_low = 0
+ ITRW_high = 0
+
+C generate NEVENT events (might be just 1 per call)
+
+ else if(NEVENT.gt.0) then
+
+ NITER = NITER+NEVENT
+
+ DO 200 I=1,NEVENT
+
+C sample y1, y2
+ 150 CONTINUE
+ ITRY_low = ITRY_low+1
+ if(ITRY_low.eq.1000000) then
+ ITRY_low = 0
+ ITRY_high = ITRY_high+1
+ endif
+
+ 175 CONTINUE
+ ITRW_low = ITRW_low+1
+ if(ITRW_low.eq.1000000) then
+ ITRW_low = 0
+ ITRW_high = ITRW_high+1
+ endif
+
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ IF(Y1*Y2.LT.ECFRAC) GOTO 175
+ IF(ISWMDL(10).GE.2) THEN
+ YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
+ YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
+ ELSE
+ YEFF1 = 1.D0+(1.D0-Y1)**2
+ YEFF2 = 1.D0+(1.D0-Y2)**2
+ ENDIF
+
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
+ Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (YEFF1*Q2LOG1
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *(YEFF2*Q2LOG2
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,4E12.5)')
+ & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
+
+C limit on Ecm_gg (app. cut, precise cut applied later)
+ GGECM2 = 4.D0*Y1*Y2*EE1*EE2
+ if(GGECM2.lt.ECMIN2) goto 175
+
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+
+ IF(IPAMDL(174).EQ.1) THEN
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
+ PINI(4,1) = EE1
+ PINI(5,1) = ELEM
+C photon 1
+ PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
+ PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
+ & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
+ IF(PT2.LT.0.D0) GOTO 175
+ PT = SQRT(PT2)
+ CALL PHO_SFECFE(SIF1,COF1)
+ P1(1) = COF1*PT
+ P1(2) = SIF1*PT
+ P1(3) = PP
+ P1(4) = EE1*Y1
+C outgoing electron 1
+ PFIN(1,1) = -P1(1)
+ PFIN(2,1) = -P1(2)
+ PFIN(3,1) = PINI(3,1)-P1(3)
+ PFIN(4,1) = PINI(4,1)-P1(4)
+ PFIN(5,1) = ELEM
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C photon 2
+ PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
+ PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
+ & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
+ IF(PT2.LT.0.D0) GOTO 175
+ PT = SQRT(PT2)
+ CALL PHO_SFECFE(SIF2,COF2)
+ P2(1) = COF2*PT
+ P2(2) = SIF2*PT
+ P2(3) = PP
+ P2(4) = EE2*Y2
+C outgoing electron 2
+ PFIN(1,2) = -P2(1)
+ PFIN(2,2) = -P2(2)
+ PFIN(3,2) = PINI(3,2)-P2(3)
+ PFIN(4,2) = PINI(4,2)-P2(4)
+ PFIN(5,2) = ELEM
+
+C precise ECMS cut
+
+ GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
+ GGECM = SQRT(GGECM2)
+
+C beam lepton detector acceptance
+
+C lepton tagger 1
+ CPFTHE = PFIN(3,1)/PFIN(4,1)
+ ITG1 = 0
+ IF(PFIN(4,1).GE.EEMIN1) THEN
+ IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
+ ENDIF
+
+C lepton tagger 2
+ CPFTHE = PFIN(3,2)/PFIN(4,2)
+ ITG2 = 0
+ IF(PFIN(4,2).GE.EEMIN2) THEN
+ IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
+ ENDIF
+
+C beam lepton taggers
+
+C anti-tag
+ IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
+ IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
+C tag
+ IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
+ IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
+C single-tag inclusive
+ IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
+ & GOTO 175
+C single-tag/anti-tag
+ IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
+ & GOTO 175
+
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+
+C photon helicities
+ IF(ISWMDL(10).GE.2) THEN
+ WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
+ WGHL = 2.D0*(1-Y1)
+ IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
+ IGHEL(1) = 1
+ ELSE
+ IGHEL(1) = 0
+ ENDIF
+ WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
+ WGHL = 2.D0*(1-Y2)
+ IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
+ IGHEL(2) = 1
+ ELSE
+ IGHEL(2) = 0
+ ENDIF
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHETRY(K) = IHETRY(K)+1
+ ELSE
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+ ENDIF
+
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+
+ WGFX = 1.D0
+C reweight according to LO photon emission diagrams (Budnev et al.)
+ IF(IPAMDL(116).GE.1) THEN
+ CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
+ WGFX = FLXQPM/FLXAPP
+ if(WGFX.gt.1.D0) then
+ WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
+ & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
+ & Y1,Y2,Q2P1,Q2P2,GGECM
+ endif
+ ENDIF
+
+C event generation
+* IVWGHT(1) = 1
+* EVWGHT(1) = MAX(WGFX,1.D0)
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+ IF(ISWMDL(10).GE.2) THEN
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHEAC1(K) = IHEAC1(K)+1
+ ENDIF
+
+C reweight according to QPM model (e+e- collider only)
+ IF((KHDIR.GT.0).AND.
+ & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
+ CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
+ WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
+ IF(DT_RNDM(WG).GT.WG) GOTO 150
+ ELSE IF(IPAMDL(116).GE.1) THEN
+ IF(DT_RNDM(WG).GT.WGFX) GOTO 150
+ ENDIF
+
+C polar angle
+ PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
+ PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
+C azimuthal angle
+ PFPHI(1) = ATAN2(COF1,SIF1)
+ PFPHI(2) = ATAN2(COF2,SIF2)
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ AN1MIN = MIN(AN1MIN,PFTHE(1))
+ AN2MIN = MIN(AN2MIN,PFTHE(2))
+ AN1MAX = MAX(AN1MAX,PFTHE(1))
+ AN2MAX = MAX(AN2MAX,PFTHE(2))
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+ Q21AVE = Q21AVE+Q2P1
+ Q22AVE = Q22AVE+Q2P2
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ IF(ISWMDL(10).GE.2) THEN
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHEAC2(K) = IHEAC2(K)+1
+ ENDIF
+
+C external histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+
+C final cross section calculation and event generation summary
+
+ else if(NEVENT.eq.-2) then
+
+* EVWGHT(1) = 1.D0
+* IVWGHT(1) = 0
+ DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
+ DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
+ WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
+ WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ Q21AVE = Q21AVE/DBLE(NITER)
+ Q21AV2 = Q21AV2/DBLE(NITER)
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
+ EE1 = WEIGHT
+ EE2 = SIGMAX*DBLE(NITER)/DITRY
+
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',WEIGHT,' mb *****',
+ & '========================================================='
+ WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
+ & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
+ & Q22MIN,Q22MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
+ & AN1MIN,AN1MAX
+ WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
+ & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
+
+ IF(ISWMDL(10).GE.2) THEN
+ WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
+ & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
+ & 'tried: ',IHETRY,
+ & 'accepted (1): ',IHEAC1,
+ & 'accepted (2): ',IHEAC2
+ ENDIF
+
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_GGEPEM: no output of histograms',NITER
+ ENDIF
+
+ endif
+
+ END
+
+*$ CREATE PHO_WGEPEM.FOR
+*COPY PHO_WGEPEM
+CDECK ID>, PHO_WGEPEM
+ SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
+C**********************************************************************
+C
+C calculate cross section weights for
+C fully differential equivalent (improved) photon approximation
+C and/or
+C fully differential QPM model with exact one-photon exchange graphs
+C
+C (unpolarized lepton beams)
+C
+C input: IMODE 0 flux calculation only
+C 1 flux folded with QPM cross section
+C /POFSRC/ photon and electron momenta
+C /POPRCS/ process type
+C /POCKIN/ kinematics of hard scattering
+C
+C output: WGHAPP weight of event according to approximation
+C WGHQPM weight of event according to one-photon exchange
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION WGHAPP,WGHQPM
+ INTEGER IMODE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
+ & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
+ & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
+ & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
+ & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
+ & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+
+ INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
+
+ DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
+ DIMENSION HELFLX(6),SIGQPM(6)
+
+ WGHAPP = 1.D0
+ WGHQPM = 0.D0
+
+C strict pt cutoff after putting partons on mass shell,
+C calculated in gamma-gamma CMS
+ if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
+ if(PTfin.lt.PTwant) then
+ if(ipamdl(121).gt.1) return
+ if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
+ endif
+ endif
+
+C cross section of sampled event (approximate treatment)
+
+C photon flux
+ DO 50 K=1,2
+ XM2(K) = AMSRC(K)**2
+ IF(abs(IGHEL(K)).EQ.1) THEN
+ WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
+ & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
+ ELSE
+ WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
+ ENDIF
+ 50 CONTINUE
+
+ W2 = GGECM*GGECM
+ IDIR = 0
+ WGHQQ = 1.D0
+
+C direct or single-resolved gam-gam interaction
+ IF((IMODE.GE.1).AND.
+ & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
+ IDIR = 1
+ WGHQQ = 0.D0
+C determine final state partons
+ DO 100 I=3,NHEP
+ IF(ISTHEP(I).EQ.25) GOTO 110
+ 100 CONTINUE
+ WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
+ & 'inconsistent process information (MSPR)',MSPR
+ CALL PHO_ABORT
+ 110 CONTINUE
+ IPOS = I
+C final state flavors
+ IPFL1 = ABS(IDHEP(IPOS+3))
+ IPFL2 = ABS(IDHEP(IPOS+4))
+ SH = X1*X2*W2
+C calculate alpha-em
+ ALPHA1 = pho_alphae(QQAL)
+C calculate alpha-s
+ IF(MSPR.LT.14) THEN
+ ALPHA2 = PHO_ALPHAS(QQAL,3)
+ ENDIF
+C LO matrix element (8 pi s dsig/dt)
+* QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
+ QC2 = Q_ch2(IPFL2)
+ IF(IPFL2.EQ.0) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
+ & 'invalid hard process - flavor combination',
+ & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
+ ENDIF
+ IF(MSPR.EQ.10) THEN
+ WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.11) THEN
+ WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.12) THEN
+ WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.13) THEN
+ WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.14) THEN
+ WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ENDIF
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+ WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
+
+C full leading-order QPM prediction (Budnev et al.)
+
+C full two-gamma flux
+
+ P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
+ & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
+ P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
+ & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
+ Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
+ & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
+ P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
+ & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
+ DO 120 I=1,4
+ P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
+ P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
+ 120 CONTINUE
+ XTM1 = 2.D0*P1Q2-Q1Q2
+ XTM2 = 2.D0*P2Q1-Q1Q2
+ XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
+ XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
+ YCAP = P1P2**2-XM2(1)*XM2(2)
+ CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
+
+ RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
+ RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
+ RHO100 = XTM1**2/XCAP-1.D0
+ RHO200 = XTM2**2/XCAP-1.D0
+ RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
+ RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
+ SS = 2.D0*P1P2+XM2(1)+XM2(2)
+
+ HELFLX(1) = 4.D0*RHO1PP*RHO2PP
+ HELFLX(2) = RHOPM2
+ HELFLX(3) = 2.D0*RHO1PP*RHO200
+ HELFLX(4) = 2.D0*RHO100*RHO2PP
+ HELFLX(5) = RHO100*RHO200
+ HELFLX(6) = -RHOP08
+
+C only flux calculation
+
+ IF(IDIR.EQ.0) THEN
+ IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
+ WEIGHT = HELFLX(1)
+ ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
+ WEIGHT = HELFLX(3)
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
+ WEIGHT = HELFLX(4)
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
+ WEIGHT = HELFLX(5)
+ ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
+ WEIGHT = HELFLX(1)
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
+ WEIGHT = 0.D0
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+ WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
+ & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
+
+ ELSE
+
+C flux folded with cross section
+C polarized, leading order gam gam --> q qbar cross sections
+
+ DO 125 I=1,6
+ SIGQPM(I) = 0.D0
+ 125 CONTINUE
+C momenta of produced parton pair
+ I1 = IPOS+3
+ I2 = IPOS+4
+ DO 150 K=1,4
+ XK1(K) = PHEP(K,I1)
+ XK2(K) = PHEP(K,I2)
+ 150 CONTINUE
+ XQ2 = PHEP(5,I2)**2
+
+ IF(MSPR.EQ.14) THEN
+C direct photon-photon interaction
+ XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
+ & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
+ & +(PGAM(3,1)-XK1(3))**2
+ XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
+ & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
+ & +(PGAM(3,1)-XK2(3))**2
+ CC = Q1Q2
+ AA = XKAP*XKAM-GQ2(1)*GQ2(2)
+ BB = CC**2-XKAP*XKAM
+ DD = CC**2-GQ2(1)*GQ2(2)
+ RR = -XQ2+W2*AA/(4.D0*DD)
+ Q1KK = Q1Q2-GQ2(1)
+ Q2KK = Q1Q2-GQ2(2)
+ FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
+
+ ELSE
+C single-resolved photon-hadron interactions
+C Mandelstam variables
+ IF(MSPR.LE.11) THEN
+ TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
+ & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
+ UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
+ & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
+ ELSE
+ TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
+ & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
+ UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
+ & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
+ ENDIF
+ V = TH/SH
+ U = UH/SH
+ ENDIF
+
+ WEIGHT = 0.D0
+ IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
+ IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
+ IF(MSPR.EQ.10) THEN
+ Q2 = -GQ2(1)
+ SP = SH-XQ2
+ TP = UH-XQ2
+ ELSE
+ Q2 = -GQ2(2)
+ SP = SH-XQ2
+ TP = TH-XQ2
+ ENDIF
+ SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
+ & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
+ & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
+ & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
+ & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
+ & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
+ & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
+ ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
+ IF(MSPR.EQ.11) THEN
+ Q2 = -GQ2(1)
+ ELSE
+ Q2 = -GQ2(2)
+ ENDIF
+ SP = SH
+ TP = UH
+ SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
+ & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
+ & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
+ & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
+ & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
+ & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
+ & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
+ & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
+ & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
+ & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
+ & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
+ & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
+ & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
+ & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
+ & (Q2-SP-TP+XQ2)**2)
+ WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
+ SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
+ SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
+ & -2.D0*XKAP*XKAM*AA
+ SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
+ SIGQPM(2) = SWPPMM*FAC
+ WEIGHT = HELFLX(1)*SIGQPM(1)
+ & +HELFLX(2)*SIGQPM(2)
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
+ IF(MSPR.EQ.12) THEN
+ Q2 = -GQ2(2)
+ SP = SH-XQ2
+ TP = TH-XQ2
+ SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
+ & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
+ & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
+ & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
+ & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
+ & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
+ & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.13) THEN
+ Q2 = -GQ2(2)
+ SP = SH
+ TP = TH
+ SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
+ & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
+ & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
+ WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
+ & -XKAP*XKAM*Q1KK**2)/DD
+ SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
+ SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
+ & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
+ SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SIGQPM(3) = SWP0P0*FAC
+ SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
+ WEIGHT = HELFLX(3)*SIGQPM(3)
+ & +HELFLX(6)*SIGQPM(6)/2.D0
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
+ IF(MSPR.EQ.10) THEN
+ Q2 = -GQ2(1)
+ SP = SH-XQ2
+ TP = UH-XQ2
+ SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
+ & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
+ & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
+ & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
+ & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
+ & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
+ & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
+ ELSE IF(MSPR.EQ.11) THEN
+ Q2 = -GQ2(1)
+ SP = SH
+ TP = TH
+ SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
+ & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
+ & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
+ WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
+ & -XKAP*XKAM*Q2KK**2)/DD
+ SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
+ SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
+ & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
+ SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SIGQPM(4) = SW0P0P*FAC
+ SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
+ WEIGHT = HELFLX(4)*SIGQPM(4)
+ & +HELFLX(6)*SIGQPM(6)/2.D0
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
+ IF(MSPR.EQ.14) THEN
+ SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
+ SIGQPM(5) = SW0000*FAC
+ WEIGHT = HELFLX(5)*SIGQPM(5)
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
+ WEIGHT = 0.D0
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+
+ WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
+ & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGBLSR.FOR
+*COPY PHO_GGBLSR
+CDECK ID>, PHO_GGBLSR
+ SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
+ & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
+C***********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via laser backscattering
+C
+C input: EE1 lab. system energy of electron/positron 1
+C EE2 lab. system energy of electron/positron 2
+C NEVENT number of events to generate
+C Pl_lam_1/2 product of electron and photon pol.
+C X_1/2 standard X parameter
+C rho ratio of distance to conversion point and
+C transverse beam size
+C A ellipticity of electon beam
+C
+C (see Ginzburg & Kotkin hep-ph/9905462)
+C
+C from /LEPCUT/:
+C YMIN1 lower limit of Y1
+C (energy fraction taken by photon from electron)
+C YMAX1 upper limit of Y1
+C YMIN2 lower limit of Y2
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y2
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ parameter (N_dim=100)
+ dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
+ & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
+ & Xgrid(96),Wgrid(96)
+
+ DIMENSION P1(4),P2(4)
+
+ Pi2 = 2.D0*Pi
+
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
+
+ YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
+ YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
+ IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
+ WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
+ & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
+ RETURN
+ ENDIF
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+
+C initialize sampling
+
+ Max_tab = 50
+ DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
+ DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
+
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GGBLSR: table of photon flux ',Max_tab
+
+ DO 100 I=1,Max_tab
+
+ y1 = YMIN1+DELY1*DBLE(I-1)
+ r1 = y1/(X_1*(1.D0-y1))
+ X_inp_1(i) = y1
+ F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
+ & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
+
+ y2 = YMIN2+DELY2*DBLE(I-1)
+ r2 = y2/(X_2*(1.D0-y2))
+ X_inp_2(i) = y2
+ F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
+ & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
+
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
+ & y1,F_inp_1(i),y2,F_inp_2(i)
+
+ 100 CONTINUE
+
+ call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
+ call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
+
+C initialize event generator
+
+C photon 1
+ EGAM = YMAX1*EE1
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+
+ call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
+ call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
+
+ g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
+ g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
+ if(abs(1.D0-A).lt.1.D-3) then
+ v = rho**2/4.D0*g_1*g_2
+ Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
+ else
+ Nint = 16
+ call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
+ A2 = A**2
+ fac = rho**2/(4.D0*(1.D0+A2))
+ Wght = 0.D0
+ do i1=1,Nint
+ phi_1 = Xgrid(i1)
+ do i2=1,Nint
+ phi_2 = Xgrid(i2)
+ Wght = Wght
+ & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
+ & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
+ & *Wgrid(i1)*Wgrid(i2)
+ enddo
+ enddo
+ Wght = Wght/Pi2**2
+ endif
+
+ IF(Wght.GT.1.D0) THEN
+ WRITE(LO,'(1X,A,5E11.4)')
+ & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
+ ENDIF
+ IF(DT_RNDM(dum).GT.Wght) GOTO 175
+
+ Y1 = X_out_1
+ Y2 = X_out_2
+
+ Q2P1 = 0.D0
+ Q2P2 = 0.D0
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1
+ PINI(4,1) = EE1
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P2)
+ Q2E = Q2P1/(4.D0*EE1)
+ E1Y = EE1*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+
+ WGY = DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
+
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE pho_samp1d.FOR
+*COPY pho_samp1d
+CDECK ID>, pho_samp1d
+ SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
+C***********************************************************************
+C
+C Monte Carlo sampling from arbitrary 1d distribution
+C (linear interpolation to improve reproduction of initial function)
+C
+C input: Imode -1 initialization
+C 1 sampling (after initialization)
+C X_inp(N_dim) array with x values
+C F_inp(N_dim) array with function values
+C F_int(N_dim) array with integral
+C
+C output: X_out sampled value (Imode=1)
+C
+C (R.E. 10/99)
+C
+C***********************************************************************
+ implicit none
+ save
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer Imode,N_dim
+ double precision X_inp,F_inp,F_int,X_out
+ dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
+
+C local variables
+ integer i
+ double precision dum,xi,a,b
+
+C external functions
+ double precision DT_RNDM
+ external DT_RNDM
+
+ if(Imode.eq.-1) then
+
+C initialization
+
+ F_int(1) = 0.D0
+ do i=2,N_dim
+ F_int(i) = F_int(i-1)
+ & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
+ enddo
+
+ else if(Imode.eq.1) then
+
+C sample from previously calculated integral
+
+ xi = DT_RNDM(dum)*F_int(N_dim)
+
+ do i=2,N_dim
+ if(xi.lt.F_int(i)) then
+ a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
+ b = F_inp(i)-a*X_inp(i)
+ xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
+ X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
+ return
+ endif
+ enddo
+ X_out = X_inp(N_dim)
+
+ else
+
+C invalid option Imode
+
+ WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
+ X_out = 0.D0
+
+ endif
+
+ END
+
+*$ CREATE pho_ExpBessI0.FOR
+*COPY pho_ExpBessI0
+CDECK ID>, pho_ExpBessI0
+ DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
+C**********************************************************************
+C
+C Bessel Function I0 times exponential function from neg. arg.
+C (defined for pos. arguments only)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ pho_ExpBessI0 =
+ & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
+ & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
+ ELSE
+ Y = 3.75D0/AX
+ pho_ExpBessI0 =
+ & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
+ & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
+ & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
+ & +Y*0.392377D-2))))))))
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGBEAM.FOR
+*COPY PHO_GGBEAM
+CDECK ID>, PHO_GGBEAM
+ SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via beamstrahlung
+C
+C input: EE LAB system energy of electron/positron
+C YPSI beamstrahlung parameter
+C SIGX,Y transverse bunch dimensions
+C SIGZ longitudinal bunch dimension
+C AEB number of electrons/positrons in a bunch
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1 lower limit of Y
+C (energy fraction taken by photon from electron)
+C YMAX1 upper cutoff for Y, necessary to avoid
+C underflows
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ PARAMETER (Max_tab=100)
+ DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
+
+C
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
+C electron data
+ RE = 2.818D-12
+ ELEM = 0.512D-03
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+C table of flux function, log interpolation
+ IF(YPSI.LE.0.D0) THEN
+ YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
+ ENDIF
+ WRITE(LO,'(/1X,A,E12.4)')
+ & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
+ TT = 2.D0/3.D0
+ OT = 1.D0/3.D0
+C GAOT = DGAMMA(OT)
+ GAOT = 2.6789385347D0
+ AKAP = TT/YPSI
+ WW = 1.D0/(6.D0*SQRT(AKAP))
+ ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
+ & *YPSI/SQRT(1.D0+YPSI**TT)
+
+ YMIN = YMIN1
+ YMAX = MIN(YMAX1,0.9D0)
+ TABCU(0) = 0.D0
+ TABYL(0) = LOG(YMIN)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GGBEAM: table of photon flux',Max_tab
+ DO 100 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
+ FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
+ & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
+ & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
+ TABCU(I) = TABCU(I-1)+FF*Y
+ TABYL(I) = LOG(Y)
+ FLUX = FLUX+Y*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
+ 100 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGBEAM: integrated flux (one side):',FLUX
+
+ EE1 = EE
+ EE2 = EE
+C photon 1
+ EGAM = YMAX*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ XI = DT_RNDM(AY1)*TABCU(Max_tab)
+ DO 110 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y1 = EXP(Y1)
+ GOTO 120
+ ENDIF
+ 110 CONTINUE
+ Y1 = YMAX
+ 120 CONTINUE
+ XI = DT_RNDM(AY2)*TABCU(Max_tab)
+ DO 130 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y2 = EXP(Y2)
+ GOTO 140
+ ENDIF
+ 130 CONTINUE
+ Y2 = YMAX
+ 140 CONTINUE
+
+ Q2P1 = 0.D0
+ Q2P2 = 0.D0
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1
+ PINI(4,1) = EE1
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P2)
+ Q2E = Q2P1/(4.D0*EE1)
+ E1Y = EE1*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+**sr leading tab removed
+ GGECML = LOG(GGECM)
+**
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,2I10)')
+ & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGHIOF.FOR
+*COPY PHO_GGHIOF
+CDECK ID>, PHO_GGHIOF
+ SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via heavy ions (form factor approach)
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX1,2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C currently implemented approximation similar to:
+C E.Papageorgiu PhysLettB250(1990)155
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4),BIMP(2,2)
+
+C
+ WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
+ & '--------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+C correct Q2MAX1,2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(1) = HIMASS
+C kinematic limitations
+ YMI = (ECMIN/(2.D0*EE))**2
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
+ & Q2MAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
+ CALL PHO_ABORT
+ ENDIF
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX1
+ YMIN = YMIN1
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 100 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
+ YMAX1 = MIN(Y1,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX2
+ IF(YMI.GT.YMIN1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
+ YMIN1 = YMI
+ ENDIF
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX1
+ IF(YMI.GT.YMIN2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
+ YMIN2 = YMI
+ ENDIF
+C
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y1*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGHIOF: integrated flux (one side):',FLUX
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+C
+C photon 1
+ EGAM = YMAX1*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ ECFRAC = ECMIN**2/(4.D0*EE*EE)
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+C sample y1, y2
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ IF(Y1*Y2.LT.ECFRAC) GOTO 175
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) GOTO 175
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,4E12.5)')
+ & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y1)**2
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(1) = 1.D0/SQRT(Q2P1)
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF21 = 1.D0
+ IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
+ FF22 = 1.D0
+ IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
+ IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
+C do the hadrons overlap?
+ IF(ISWMDL(26).GT.0) THEN
+ DO 190 K=1,2
+ CALL PHO_SFECFE(SIF,COF)
+ BIMP(1,K) = SIF*GAIMP(K)
+ BIMP(2,K) = COF*GAIMP(K)
+ 190 CONTINUE
+ BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
+ & +(BIMP(2,1)-BIMP(2,2))**2)
+ IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
+ ENDIF
+C photon data
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C
+
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE
+ PINI(4,1) = EE
+ PINI(5,1) = 0.D0
+C outgoing hadron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P1)
+ Q2E = Q2P1/(4.D0*EE)
+ E1Y = EE*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+ PFPHI(1) = ATAN2(COF,SIF)
+ PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE
+ PINI(4,2) = EE
+ PINI(5,2) = 0.D0
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+ Q21AVE = Q21AVE+Q2P1
+ Q22AVE = Q22AVE+Q2P2
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
+ WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ Q21AVE = Q21AVE/DBLE(NITER)
+ Q21AV2 = Q21AV2/DBLE(NITER)
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGHIOG.FOR
+*COPY PHO_GGHIOG
+CDECK ID>, PHO_GGHIOG
+ SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via heavy ions (geometrical approach)
+C
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C
+C currently implemented approximation similar to:
+C
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ PARAMETER (Max_tab=100)
+ DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
+
+C
+ WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
+ & '---------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(1) = HIMASS
+C kinematic limitations
+ YMI = (ECMIN/(2.D0*EE))**2
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+C table of flux function, log interpolation
+ YMIN = YMIN1
+ YMAX = YMAX1
+ YMAX = MIN(YMAX,0.9999999D0)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABYL(0) = LOG(YMIN)
+ FFMAX = 0.D0
+ DO 100 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ IF(FF.LT.1.D-10*FFMAX) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
+ YMAX1 = MIN(Y,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMIN = YMIN2
+ YMAX = YMAX2
+ YMAX = MIN(YMAX,0.9999999D0)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABYL(0) = LOG(YMIN)
+ FFMAX = 0.D0
+ DO 102 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ IF(FF.LT.1.D-10*FFMAX) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
+ YMAX2 = MIN(Y,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX2
+ IF(YMI.GT.YMIN1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
+ YMIN1 = YMI
+ ENDIF
+ YMAX1 = MIN(YMAX,YMAX1)
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX1
+ IF(YMI.GT.YMIN2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
+ YMIN2 = YMI
+ ENDIF
+C
+ YMIN = YMIN1
+ YMAX = YMAX1
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABCU(0) = 0.D0
+ TABYL(0) = LOG(YMIN)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ TABCU(I) = TABCU(I-1)+FF*Y
+ TABYL(I) = LOG(Y)
+ FLUX = FLUX+Y*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGHIOG: integrated flux (one side):',FLUX
+C
+C initialization
+C photon 1
+ EGAM = YMAX*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ XI = DT_RNDM(AY1)*TABCU(Max_tab)
+ DO 110 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y1 = EXP(Y1)
+ GOTO 120
+ ENDIF
+ 110 CONTINUE
+ Y1 = YMAX1
+ 120 CONTINUE
+ XI = DT_RNDM(AY2)*TABCU(Max_tab)
+ DO 130 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y2 = EXP(Y2)
+ GOTO 140
+ ENDIF
+ 130 CONTINUE
+ Y2 = YMAX2
+ 140 CONTINUE
+C setup kinematics
+
+ GYY(1) = Y1
+ GQ2(1) = 0.D0
+ GYY(2) = Y2
+ GQ2(2) = 0.D0
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE
+ PINI(4,1) = EE
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ E1Y = EE*(1.D0-Y1)
+ PFIN(1,1) = 0.D0
+ PFIN(2,1) = 0.D0
+ PFIN(3,1) = E1Y
+ PFIN(4,1) = E1Y
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE
+ PINI(4,2) = EE
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ E1Y = EE*(1.D0-Y2)
+ PFIN(1,2) = 0.D0
+ PFIN(2,2) = 0.D0
+ PFIN(3,2) = -E1Y
+ PFIN(4,2) = E1Y
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C impact parameter constraints
+ XI1 = P1(4)*HIRADI/GAMMA
+ XI2 = P2(4)*HIRADI/GAMMA
+ FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
+ FCORR = PHO_GGFLCR(HIRADI)
+ WGX = (FLX-FCORR)/FLX
+ IF(DT_RNDM(Y2).GT.WGX) GOTO 175
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I12)')
+ & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GGFLCL.FOR
+*COPY PHO_GGFLCL
+CDECK ID>, PHO_GGFLCL
+ DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
+C*********************************************************************
+C
+C semi-classical photon flux (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
+ & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
+
+ END
+
+*$ CREATE PHO_GGFLCR.FOR
+*COPY PHO_GGFLCR
+CDECK ID>, PHO_GGFLCR
+ DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
+C*********************************************************************
+C
+C semi-classical photon flux correction due to
+C overlap in impact parameter space (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+
+ DIMENSION XGAUSS(126),WGAUSS(126)
+
+ DATA XGAUSS(1)/ .57735026918962576D0/
+ DATA XGAUSS(2)/-.57735026918962576D0/
+ DATA WGAUSS(1)/ 1.00000000000000000D0/
+ DATA WGAUSS(2)/ 1.00000000000000000D0/
+
+ DATA XGAUSS(3)/ .33998104358485627D0/
+ DATA XGAUSS(4)/ .86113631159405258D0/
+ DATA XGAUSS(5)/-.33998104358485627D0/
+ DATA XGAUSS(6)/-.86113631159405258D0/
+ DATA WGAUSS(3)/ .65214515486254613D0/
+ DATA WGAUSS(4)/ .34785484513745385D0/
+ DATA WGAUSS(5)/ .65214515486254613D0/
+ DATA WGAUSS(6)/ .34785484513745385D0/
+
+ DATA XGAUSS(7)/ .18343464249564981D0/
+ DATA XGAUSS(8)/ .52553240991632899D0/
+ DATA XGAUSS(9)/ .79666647741362674D0/
+ DATA XGAUSS(10)/ .96028985649753623D0/
+ DATA XGAUSS(11)/-.18343464249564981D0/
+ DATA XGAUSS(12)/-.52553240991632899D0/
+ DATA XGAUSS(13)/-.79666647741362674D0/
+ DATA XGAUSS(14)/-.96028985649753623D0/
+ DATA WGAUSS(7)/ .36268378337836198D0/
+ DATA WGAUSS(8)/ .31370664587788727D0/
+ DATA WGAUSS(9)/ .22238103445337448D0/
+ DATA WGAUSS(10)/ .10122853629037627D0/
+ DATA WGAUSS(11)/ .36268378337836198D0/
+ DATA WGAUSS(12)/ .31370664587788727D0/
+ DATA WGAUSS(13)/ .22238103445337448D0/
+ DATA WGAUSS(14)/ .10122853629037627D0/
+
+ DATA XGAUSS(15)/ .0950125098376374402D0/
+ DATA XGAUSS(16)/ .281603550779258913D0/
+ DATA XGAUSS(17)/ .458016777657227386D0/
+ DATA XGAUSS(18)/ .617876244402643748D0/
+ DATA XGAUSS(19)/ .755404408355003034D0/
+ DATA XGAUSS(20)/ .865631202387831744D0/
+ DATA XGAUSS(21)/ .944575023073232576D0/
+ DATA XGAUSS(22)/ .989400934991649933D0/
+ DATA XGAUSS(23)/-.0950125098376374402D0/
+ DATA XGAUSS(24)/-.281603550779258913D0/
+ DATA XGAUSS(25)/-.458016777657227386D0/
+ DATA XGAUSS(26)/-.617876244402643748D0/
+ DATA XGAUSS(27)/-.755404408355003034D0/
+ DATA XGAUSS(28)/-.865631202387831744D0/
+ DATA XGAUSS(29)/-.944575023073232576D0/
+ DATA XGAUSS(30)/-.989400934991649933D0/
+ DATA WGAUSS(15)/ .189450610455068496D0/
+ DATA WGAUSS(16)/ .182603415044923589D0/
+ DATA WGAUSS(17)/ .169156519395002538D0/
+ DATA WGAUSS(18)/ .149595988816576732D0/
+ DATA WGAUSS(19)/ .124628971255533872D0/
+ DATA WGAUSS(20)/ .0951585116824927848D0/
+ DATA WGAUSS(21)/ .0622535239386478929D0/
+ DATA WGAUSS(22)/ .0271524594117540949D0/
+ DATA WGAUSS(23)/ .189450610455068496D0/
+ DATA WGAUSS(24)/ .182603415044923589D0/
+ DATA WGAUSS(25)/ .169156519395002538D0/
+ DATA WGAUSS(26)/ .149595988816576732D0/
+ DATA WGAUSS(27)/ .124628971255533872D0/
+ DATA WGAUSS(28)/ .0951585116824927848D0/
+ DATA WGAUSS(29)/ .0622535239386478929D0/
+ DATA WGAUSS(30)/ .0271524594117540949D0/
+
+ DATA XGAUSS(31)/ .0483076656877383162D0/
+ DATA XGAUSS(32)/ .144471961582796493D0/
+ DATA XGAUSS(33)/ .239287362252137075D0/
+ DATA XGAUSS(34)/ .331868602282127650D0/
+ DATA XGAUSS(35)/ .421351276130635345D0/
+ DATA XGAUSS(36)/ .506899908932229390D0/
+ DATA XGAUSS(37)/ .587715757240762329D0/
+ DATA XGAUSS(38)/ .663044266930215201D0/
+ DATA XGAUSS(39)/ .732182118740289680D0/
+ DATA XGAUSS(40)/ .794483795967942407D0/
+ DATA XGAUSS(41)/ .849367613732569970D0/
+ DATA XGAUSS(42)/ .896321155766052124D0/
+ DATA XGAUSS(43)/ .934906075937739689D0/
+ DATA XGAUSS(44)/ .964762255587506430D0/
+ DATA XGAUSS(45)/ .985611511545268335D0/
+ DATA XGAUSS(46)/ .997263861849481564D0/
+ DATA XGAUSS(47)/-.0483076656877383162D0/
+ DATA XGAUSS(48)/-.144471961582796493D0/
+ DATA XGAUSS(49)/-.239287362252137075D0/
+ DATA XGAUSS(50)/-.331868602282127650D0/
+ DATA XGAUSS(51)/-.421351276130635345D0/
+ DATA XGAUSS(52)/-.506899908932229390D0/
+ DATA XGAUSS(53)/-.587715757240762329D0/
+ DATA XGAUSS(54)/-.663044266930215201D0/
+ DATA XGAUSS(55)/-.732182118740289680D0/
+ DATA XGAUSS(56)/-.794483795967942407D0/
+ DATA XGAUSS(57)/-.849367613732569970D0/
+ DATA XGAUSS(58)/-.896321155766052124D0/
+ DATA XGAUSS(59)/-.934906075937739689D0/
+ DATA XGAUSS(60)/-.964762255587506430D0/
+ DATA XGAUSS(61)/-.985611511545268335D0/
+ DATA XGAUSS(62)/-.997263861849481564D0/
+ DATA WGAUSS(31)/ .0965400885147278006D0/
+ DATA WGAUSS(32)/ .0956387200792748594D0/
+ DATA WGAUSS(33)/ .0938443990808045654D0/
+ DATA WGAUSS(34)/ .0911738786957638847D0/
+ DATA WGAUSS(35)/ .0876520930044038111D0/
+ DATA WGAUSS(36)/ .0833119242269467552D0/
+ DATA WGAUSS(37)/ .0781938957870703065D0/
+ DATA WGAUSS(38)/ .0723457941088485062D0/
+ DATA WGAUSS(39)/ .0658222227763618468D0/
+ DATA WGAUSS(40)/ .0586840934785355471D0/
+ DATA WGAUSS(41)/ .0509980592623761762D0/
+ DATA WGAUSS(42)/ .0428358980222266807D0/
+ DATA WGAUSS(43)/ .0342738629130214331D0/
+ DATA WGAUSS(44)/ .0253920653092620595D0/
+ DATA WGAUSS(45)/ .0162743947309056706D0/
+ DATA WGAUSS(46)/ .00701861000947009660D0/
+ DATA WGAUSS(47)/ .0965400885147278006D0/
+ DATA WGAUSS(48)/ .0956387200792748594D0/
+ DATA WGAUSS(49)/ .0938443990808045654D0/
+ DATA WGAUSS(50)/ .0911738786957638847D0/
+ DATA WGAUSS(51)/ .0876520930044038111D0/
+ DATA WGAUSS(52)/ .0833119242269467552D0/
+ DATA WGAUSS(53)/ .0781938957870703065D0/
+ DATA WGAUSS(54)/ .0723457941088485062D0/
+ DATA WGAUSS(55)/ .0658222227763618468D0/
+ DATA WGAUSS(56)/ .0586840934785355471D0/
+ DATA WGAUSS(57)/ .0509980592623761762D0/
+ DATA WGAUSS(58)/ .0428358980222266807D0/
+ DATA WGAUSS(59)/ .0342738629130214331D0/
+ DATA WGAUSS(60)/ .0253920653092620595D0/
+ DATA WGAUSS(61)/ .0162743947309056706D0/
+ DATA WGAUSS(62)/ .00701861000947009660D0/
+
+ DATA XGAUSS(63)/ .02435029266342443250D0/
+ DATA XGAUSS(64)/ .0729931217877990394D0/
+ DATA XGAUSS(65)/ .121462819296120554D0/
+ DATA XGAUSS(66)/ .169644420423992818D0/
+ DATA XGAUSS(67)/ .217423643740007084D0/
+ DATA XGAUSS(68)/ .264687162208767416D0/
+ DATA XGAUSS(69)/ .311322871990210956D0/
+ DATA XGAUSS(70)/ .357220158337668116D0/
+ DATA XGAUSS(71)/ .402270157963991604D0/
+ DATA XGAUSS(72)/ .446366017253464088D0/
+ DATA XGAUSS(73)/ .489403145707052957D0/
+ DATA XGAUSS(74)/ .531279464019894546D0/
+ DATA XGAUSS(75)/ .571895646202634034D0/
+ DATA XGAUSS(76)/ .611155355172393250D0/
+ DATA XGAUSS(77)/ .648965471254657340D0/
+ DATA XGAUSS(78)/ .685236313054233243D0/
+ DATA XGAUSS(79)/ .719881850171610827D0/
+ DATA XGAUSS(80)/ .752819907260531897D0/
+ DATA XGAUSS(81)/ .783972358943341408D0/
+ DATA XGAUSS(82)/ .813265315122797560D0/
+ DATA XGAUSS(83)/ .840629296252580363D0/
+ DATA XGAUSS(84)/ .865999398154092820D0/
+ DATA XGAUSS(85)/ .889315445995114106D0/
+ DATA XGAUSS(86)/ .910522137078502806D0/
+ DATA XGAUSS(87)/ .929569172131939576D0/
+ DATA XGAUSS(88)/ .946411374858402816D0/
+ DATA XGAUSS(89)/ .961008799652053719D0/
+ DATA XGAUSS(90)/ .973326827789910964D0/
+ DATA XGAUSS(91)/ .983336253884625957D0/
+ DATA XGAUSS(92)/ .991013371476744321D0/
+ DATA XGAUSS(93)/ .996340116771955279D0/
+ DATA XGAUSS(94)/ .999305041735772139D0/
+ DATA XGAUSS(95)/-.02435029266342443250D0/
+ DATA XGAUSS(96)/-.0729931217877990394D0/
+ DATA XGAUSS(97)/-.121462819296120554D0/
+ DATA XGAUSS(98)/-.169644420423992818D0/
+ DATA XGAUSS(99)/-.217423643740007084D0/
+ DATA XGAUSS(100)/-.264687162208767416D0/
+ DATA XGAUSS(101)/-.311322871990210956D0/
+ DATA XGAUSS(102)/-.357220158337668116D0/
+ DATA XGAUSS(103)/-.402270157963991604D0/
+ DATA XGAUSS(104)/-.446366017253464088D0/
+ DATA XGAUSS(105)/-.489403145707052957D0/
+ DATA XGAUSS(106)/-.531279464019894546D0/
+ DATA XGAUSS(107)/-.571895646202634034D0/
+ DATA XGAUSS(108)/-.611155355172393250D0/
+ DATA XGAUSS(109)/-.648965471254657340D0/
+ DATA XGAUSS(110)/-.685236313054233243D0/
+ DATA XGAUSS(111)/-.719881850171610827D0/
+ DATA XGAUSS(112)/-.752819907260531897D0/
+ DATA XGAUSS(113)/-.783972358943341408D0/
+ DATA XGAUSS(114)/-.813265315122797560D0/
+ DATA XGAUSS(115)/-.840629296252580363D0/
+ DATA XGAUSS(116)/-.865999398154092820D0/
+ DATA XGAUSS(117)/-.889315445995114106D0/
+ DATA XGAUSS(118)/-.910522137078502806D0/
+ DATA XGAUSS(119)/-.929569172131939576D0/
+ DATA XGAUSS(120)/-.946411374858402816D0/
+ DATA XGAUSS(121)/-.961008799652053719D0/
+ DATA XGAUSS(122)/-.973326827789910964D0/
+ DATA XGAUSS(123)/-.983336253884625957D0/
+ DATA XGAUSS(124)/-.991013371476744321D0/
+ DATA XGAUSS(125)/-.996340116771955279D0/
+ DATA XGAUSS(126)/-.999305041735772139D0/
+ DATA WGAUSS(63)/ .0486909570091397204D0/
+ DATA WGAUSS(64)/ .0485754674415034269D0/
+ DATA WGAUSS(65)/ .0483447622348029572D0/
+ DATA WGAUSS(66)/ .0479993885964583077D0/
+ DATA WGAUSS(67)/ .0475401657148303087D0/
+ DATA WGAUSS(68)/ .0469681828162100173D0/
+ DATA WGAUSS(69)/ .0462847965813144172D0/
+ DATA WGAUSS(70)/ .0454916279274181445D0/
+ DATA WGAUSS(71)/ .0445905581637565631D0/
+ DATA WGAUSS(72)/ .0435837245293234534D0/
+ DATA WGAUSS(73)/ .0424735151236535890D0/
+ DATA WGAUSS(74)/ .0412625632426235286D0/
+ DATA WGAUSS(75)/ .0399537411327203414D0/
+ DATA WGAUSS(76)/ .0385501531786156291D0/
+ DATA WGAUSS(77)/ .0370551285402400460D0/
+ DATA WGAUSS(78)/ .0354722132568823838D0/
+ DATA WGAUSS(79)/ .0338051618371416094D0/
+ DATA WGAUSS(80)/ .0320579283548515535D0/
+ DATA WGAUSS(81)/ .0302346570724024789D0/
+ DATA WGAUSS(82)/ .0283396726142594832D0/
+ DATA WGAUSS(83)/ .0263774697150546587D0/
+ DATA WGAUSS(84)/ .0243527025687108733D0/
+ DATA WGAUSS(85)/ .0222701738083832542D0/
+ DATA WGAUSS(86)/ .0201348231535302094D0/
+ DATA WGAUSS(87)/ .0179517157756973431D0/
+ DATA WGAUSS(88)/ .0157260304760247193D0/
+ DATA WGAUSS(89)/ .0134630478967186426D0/
+ DATA WGAUSS(90)/ .0111681394601311288D0/
+ DATA WGAUSS(91)/ .00884675982636394772D0/
+ DATA WGAUSS(92)/ .00650445796897836286D0/
+ DATA WGAUSS(93)/ .00414703326056246764D0/
+ DATA WGAUSS(94)/ .00178328072169643295D0/
+ DATA WGAUSS(95)/ .0486909570091397204D0/
+ DATA WGAUSS(96)/ .0485754674415034269D0/
+ DATA WGAUSS(97)/ .0483447622348029572D0/
+ DATA WGAUSS(98)/ .0479993885964583077D0/
+ DATA WGAUSS(99)/ .0475401657148303087D0/
+ DATA WGAUSS(100)/ .0469681828162100173D0/
+ DATA WGAUSS(101)/ .0462847965813144172D0/
+ DATA WGAUSS(102)/ .0454916279274181445D0/
+ DATA WGAUSS(103)/ .0445905581637565631D0/
+ DATA WGAUSS(104)/ .0435837245293234534D0/
+ DATA WGAUSS(105)/ .0424735151236535890D0/
+ DATA WGAUSS(106)/ .0412625632426235286D0/
+ DATA WGAUSS(107)/ .0399537411327203414D0/
+ DATA WGAUSS(108)/ .0385501531786156291D0/
+ DATA WGAUSS(109)/ .0370551285402400460D0/
+ DATA WGAUSS(110)/ .0354722132568823838D0/
+ DATA WGAUSS(111)/ .0338051618371416094D0/
+ DATA WGAUSS(112)/ .0320579283548515535D0/
+ DATA WGAUSS(113)/ .0302346570724024789D0/
+ DATA WGAUSS(114)/ .0283396726142594832D0/
+ DATA WGAUSS(115)/ .0263774697150546587D0/
+ DATA WGAUSS(116)/ .0243527025687108733D0/
+ DATA WGAUSS(117)/ .0222701738083832542D0/
+ DATA WGAUSS(118)/ .0201348231535302094D0/
+ DATA WGAUSS(119)/ .0179517157756973431D0/
+ DATA WGAUSS(120)/ .0157260304760247193D0/
+ DATA WGAUSS(121)/ .0134630478967186426D0/
+ DATA WGAUSS(122)/ .0111681394601311288D0/
+ DATA WGAUSS(123)/ .00884675982636394772D0/
+ DATA WGAUSS(124)/ .00650445796897836286D0/
+ DATA WGAUSS(125)/ .00414703326056246764D0/
+ DATA WGAUSS(126)/ .00178328072169643295D0/
+
+C integrate first over b1
+C
+C Loop incrementing the boundary
+C
+ tmin = 0.D0
+ tmax = 0.25D0
+ Sum = 0.D0
+
+ 50 CONTINUE
+
+C
+C Loop for the Gauss integration
+C
+ XINT=0.D0
+ DO 100 N=1,6
+ XINT2 = XINT
+ XINT=0.D0
+ DO 200 I=2**N-1,2**(N+1)-2
+ t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
+ b1 = RADSRC(1) * EXP (t)
+ XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
+ 200 CONTINUE
+ XINT = (tmax-tmin)/2.D0*XINT
+ IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
+ 100 CONTINUE
+ WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
+ 300 CONTINUE
+
+ Sum = Sum + XINT
+ IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
+ tmin = tmax
+ tmax = tmax + 0.5D0
+ GOTO 50
+ ENDIF
+
+ PHO_GGFLCR = 4.D0*Pi * Sum
+
+ END
+
+*$ CREATE PHO_GGFAUX.FOR
+*COPY PHO_GGFAUX
+CDECK ID>, PHO_GGFAUX
+ DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
+C*********************************************************************
+C
+C auxiliary function for integration over b2,
+C semi-classical photon flux correction due to
+C overlap in impact parameter space (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+
+ DIMENSION XGAUSS(126),WGAUSS(126)
+
+ DATA XGAUSS(1)/ .57735026918962576D0/
+ DATA XGAUSS(2)/-.57735026918962576D0/
+ DATA WGAUSS(1)/ 1.00000000000000000D0/
+ DATA WGAUSS(2)/ 1.00000000000000000D0/
+
+ DATA XGAUSS(3)/ .33998104358485627D0/
+ DATA XGAUSS(4)/ .86113631159405258D0/
+ DATA XGAUSS(5)/-.33998104358485627D0/
+ DATA XGAUSS(6)/-.86113631159405258D0/
+ DATA WGAUSS(3)/ .65214515486254613D0/
+ DATA WGAUSS(4)/ .34785484513745385D0/
+ DATA WGAUSS(5)/ .65214515486254613D0/
+ DATA WGAUSS(6)/ .34785484513745385D0/
+
+ DATA XGAUSS(7)/ .18343464249564981D0/
+ DATA XGAUSS(8)/ .52553240991632899D0/
+ DATA XGAUSS(9)/ .79666647741362674D0/
+ DATA XGAUSS(10)/ .96028985649753623D0/
+ DATA XGAUSS(11)/-.18343464249564981D0/
+ DATA XGAUSS(12)/-.52553240991632899D0/
+ DATA XGAUSS(13)/-.79666647741362674D0/
+ DATA XGAUSS(14)/-.96028985649753623D0/
+ DATA WGAUSS(7)/ .36268378337836198D0/
+ DATA WGAUSS(8)/ .31370664587788727D0/
+ DATA WGAUSS(9)/ .22238103445337448D0/
+ DATA WGAUSS(10)/ .10122853629037627D0/
+ DATA WGAUSS(11)/ .36268378337836198D0/
+ DATA WGAUSS(12)/ .31370664587788727D0/
+ DATA WGAUSS(13)/ .22238103445337448D0/
+ DATA WGAUSS(14)/ .10122853629037627D0/
+
+ DATA XGAUSS(15)/ .0950125098376374402D0/
+ DATA XGAUSS(16)/ .281603550779258913D0/
+ DATA XGAUSS(17)/ .458016777657227386D0/
+ DATA XGAUSS(18)/ .617876244402643748D0/
+ DATA XGAUSS(19)/ .755404408355003034D0/
+ DATA XGAUSS(20)/ .865631202387831744D0/
+ DATA XGAUSS(21)/ .944575023073232576D0/
+ DATA XGAUSS(22)/ .989400934991649933D0/
+ DATA XGAUSS(23)/-.0950125098376374402D0/
+ DATA XGAUSS(24)/-.281603550779258913D0/
+ DATA XGAUSS(25)/-.458016777657227386D0/
+ DATA XGAUSS(26)/-.617876244402643748D0/
+ DATA XGAUSS(27)/-.755404408355003034D0/
+ DATA XGAUSS(28)/-.865631202387831744D0/
+ DATA XGAUSS(29)/-.944575023073232576D0/
+ DATA XGAUSS(30)/-.989400934991649933D0/
+ DATA WGAUSS(15)/ .189450610455068496D0/
+ DATA WGAUSS(16)/ .182603415044923589D0/
+ DATA WGAUSS(17)/ .169156519395002538D0/
+ DATA WGAUSS(18)/ .149595988816576732D0/
+ DATA WGAUSS(19)/ .124628971255533872D0/
+ DATA WGAUSS(20)/ .0951585116824927848D0/
+ DATA WGAUSS(21)/ .0622535239386478929D0/
+ DATA WGAUSS(22)/ .0271524594117540949D0/
+ DATA WGAUSS(23)/ .189450610455068496D0/
+ DATA WGAUSS(24)/ .182603415044923589D0/
+ DATA WGAUSS(25)/ .169156519395002538D0/
+ DATA WGAUSS(26)/ .149595988816576732D0/
+ DATA WGAUSS(27)/ .124628971255533872D0/
+ DATA WGAUSS(28)/ .0951585116824927848D0/
+ DATA WGAUSS(29)/ .0622535239386478929D0/
+ DATA WGAUSS(30)/ .0271524594117540949D0/
+
+ DATA XGAUSS(31)/ .0483076656877383162D0/
+ DATA XGAUSS(32)/ .144471961582796493D0/
+ DATA XGAUSS(33)/ .239287362252137075D0/
+ DATA XGAUSS(34)/ .331868602282127650D0/
+ DATA XGAUSS(35)/ .421351276130635345D0/
+ DATA XGAUSS(36)/ .506899908932229390D0/
+ DATA XGAUSS(37)/ .587715757240762329D0/
+ DATA XGAUSS(38)/ .663044266930215201D0/
+ DATA XGAUSS(39)/ .732182118740289680D0/
+ DATA XGAUSS(40)/ .794483795967942407D0/
+ DATA XGAUSS(41)/ .849367613732569970D0/
+ DATA XGAUSS(42)/ .896321155766052124D0/
+ DATA XGAUSS(43)/ .934906075937739689D0/
+ DATA XGAUSS(44)/ .964762255587506430D0/
+ DATA XGAUSS(45)/ .985611511545268335D0/
+ DATA XGAUSS(46)/ .997263861849481564D0/
+ DATA XGAUSS(47)/-.0483076656877383162D0/
+ DATA XGAUSS(48)/-.144471961582796493D0/
+ DATA XGAUSS(49)/-.239287362252137075D0/
+ DATA XGAUSS(50)/-.331868602282127650D0/
+ DATA XGAUSS(51)/-.421351276130635345D0/
+ DATA XGAUSS(52)/-.506899908932229390D0/
+ DATA XGAUSS(53)/-.587715757240762329D0/
+ DATA XGAUSS(54)/-.663044266930215201D0/
+ DATA XGAUSS(55)/-.732182118740289680D0/
+ DATA XGAUSS(56)/-.794483795967942407D0/
+ DATA XGAUSS(57)/-.849367613732569970D0/
+ DATA XGAUSS(58)/-.896321155766052124D0/
+ DATA XGAUSS(59)/-.934906075937739689D0/
+ DATA XGAUSS(60)/-.964762255587506430D0/
+ DATA XGAUSS(61)/-.985611511545268335D0/
+ DATA XGAUSS(62)/-.997263861849481564D0/
+ DATA WGAUSS(31)/ .0965400885147278006D0/
+ DATA WGAUSS(32)/ .0956387200792748594D0/
+ DATA WGAUSS(33)/ .0938443990808045654D0/
+ DATA WGAUSS(34)/ .0911738786957638847D0/
+ DATA WGAUSS(35)/ .0876520930044038111D0/
+ DATA WGAUSS(36)/ .0833119242269467552D0/
+ DATA WGAUSS(37)/ .0781938957870703065D0/
+ DATA WGAUSS(38)/ .0723457941088485062D0/
+ DATA WGAUSS(39)/ .0658222227763618468D0/
+ DATA WGAUSS(40)/ .0586840934785355471D0/
+ DATA WGAUSS(41)/ .0509980592623761762D0/
+ DATA WGAUSS(42)/ .0428358980222266807D0/
+ DATA WGAUSS(43)/ .0342738629130214331D0/
+ DATA WGAUSS(44)/ .0253920653092620595D0/
+ DATA WGAUSS(45)/ .0162743947309056706D0/
+ DATA WGAUSS(46)/ .00701861000947009660D0/
+ DATA WGAUSS(47)/ .0965400885147278006D0/
+ DATA WGAUSS(48)/ .0956387200792748594D0/
+ DATA WGAUSS(49)/ .0938443990808045654D0/
+ DATA WGAUSS(50)/ .0911738786957638847D0/
+ DATA WGAUSS(51)/ .0876520930044038111D0/
+ DATA WGAUSS(52)/ .0833119242269467552D0/
+ DATA WGAUSS(53)/ .0781938957870703065D0/
+ DATA WGAUSS(54)/ .0723457941088485062D0/
+ DATA WGAUSS(55)/ .0658222227763618468D0/
+ DATA WGAUSS(56)/ .0586840934785355471D0/
+ DATA WGAUSS(57)/ .0509980592623761762D0/
+ DATA WGAUSS(58)/ .0428358980222266807D0/
+ DATA WGAUSS(59)/ .0342738629130214331D0/
+ DATA WGAUSS(60)/ .0253920653092620595D0/
+ DATA WGAUSS(61)/ .0162743947309056706D0/
+ DATA WGAUSS(62)/ .00701861000947009660D0/
+
+ DATA XGAUSS(63)/ .02435029266342443250D0/
+ DATA XGAUSS(64)/ .0729931217877990394D0/
+ DATA XGAUSS(65)/ .121462819296120554D0/
+ DATA XGAUSS(66)/ .169644420423992818D0/
+ DATA XGAUSS(67)/ .217423643740007084D0/
+ DATA XGAUSS(68)/ .264687162208767416D0/
+ DATA XGAUSS(69)/ .311322871990210956D0/
+ DATA XGAUSS(70)/ .357220158337668116D0/
+ DATA XGAUSS(71)/ .402270157963991604D0/
+ DATA XGAUSS(72)/ .446366017253464088D0/
+ DATA XGAUSS(73)/ .489403145707052957D0/
+ DATA XGAUSS(74)/ .531279464019894546D0/
+ DATA XGAUSS(75)/ .571895646202634034D0/
+ DATA XGAUSS(76)/ .611155355172393250D0/
+ DATA XGAUSS(77)/ .648965471254657340D0/
+ DATA XGAUSS(78)/ .685236313054233243D0/
+ DATA XGAUSS(79)/ .719881850171610827D0/
+ DATA XGAUSS(80)/ .752819907260531897D0/
+ DATA XGAUSS(81)/ .783972358943341408D0/
+ DATA XGAUSS(82)/ .813265315122797560D0/
+ DATA XGAUSS(83)/ .840629296252580363D0/
+ DATA XGAUSS(84)/ .865999398154092820D0/
+ DATA XGAUSS(85)/ .889315445995114106D0/
+ DATA XGAUSS(86)/ .910522137078502806D0/
+ DATA XGAUSS(87)/ .929569172131939576D0/
+ DATA XGAUSS(88)/ .946411374858402816D0/
+ DATA XGAUSS(89)/ .961008799652053719D0/
+ DATA XGAUSS(90)/ .973326827789910964D0/
+ DATA XGAUSS(91)/ .983336253884625957D0/
+ DATA XGAUSS(92)/ .991013371476744321D0/
+ DATA XGAUSS(93)/ .996340116771955279D0/
+ DATA XGAUSS(94)/ .999305041735772139D0/
+ DATA XGAUSS(95)/-.02435029266342443250D0/
+ DATA XGAUSS(96)/-.0729931217877990394D0/
+ DATA XGAUSS(97)/-.121462819296120554D0/
+ DATA XGAUSS(98)/-.169644420423992818D0/
+ DATA XGAUSS(99)/-.217423643740007084D0/
+ DATA XGAUSS(100)/-.264687162208767416D0/
+ DATA XGAUSS(101)/-.311322871990210956D0/
+ DATA XGAUSS(102)/-.357220158337668116D0/
+ DATA XGAUSS(103)/-.402270157963991604D0/
+ DATA XGAUSS(104)/-.446366017253464088D0/
+ DATA XGAUSS(105)/-.489403145707052957D0/
+ DATA XGAUSS(106)/-.531279464019894546D0/
+ DATA XGAUSS(107)/-.571895646202634034D0/
+ DATA XGAUSS(108)/-.611155355172393250D0/
+ DATA XGAUSS(109)/-.648965471254657340D0/
+ DATA XGAUSS(110)/-.685236313054233243D0/
+ DATA XGAUSS(111)/-.719881850171610827D0/
+ DATA XGAUSS(112)/-.752819907260531897D0/
+ DATA XGAUSS(113)/-.783972358943341408D0/
+ DATA XGAUSS(114)/-.813265315122797560D0/
+ DATA XGAUSS(115)/-.840629296252580363D0/
+ DATA XGAUSS(116)/-.865999398154092820D0/
+ DATA XGAUSS(117)/-.889315445995114106D0/
+ DATA XGAUSS(118)/-.910522137078502806D0/
+ DATA XGAUSS(119)/-.929569172131939576D0/
+ DATA XGAUSS(120)/-.946411374858402816D0/
+ DATA XGAUSS(121)/-.961008799652053719D0/
+ DATA XGAUSS(122)/-.973326827789910964D0/
+ DATA XGAUSS(123)/-.983336253884625957D0/
+ DATA XGAUSS(124)/-.991013371476744321D0/
+ DATA XGAUSS(125)/-.996340116771955279D0/
+ DATA XGAUSS(126)/-.999305041735772139D0/
+ DATA WGAUSS(63)/ .0486909570091397204D0/
+ DATA WGAUSS(64)/ .0485754674415034269D0/
+ DATA WGAUSS(65)/ .0483447622348029572D0/
+ DATA WGAUSS(66)/ .0479993885964583077D0/
+ DATA WGAUSS(67)/ .0475401657148303087D0/
+ DATA WGAUSS(68)/ .0469681828162100173D0/
+ DATA WGAUSS(69)/ .0462847965813144172D0/
+ DATA WGAUSS(70)/ .0454916279274181445D0/
+ DATA WGAUSS(71)/ .0445905581637565631D0/
+ DATA WGAUSS(72)/ .0435837245293234534D0/
+ DATA WGAUSS(73)/ .0424735151236535890D0/
+ DATA WGAUSS(74)/ .0412625632426235286D0/
+ DATA WGAUSS(75)/ .0399537411327203414D0/
+ DATA WGAUSS(76)/ .0385501531786156291D0/
+ DATA WGAUSS(77)/ .0370551285402400460D0/
+ DATA WGAUSS(78)/ .0354722132568823838D0/
+ DATA WGAUSS(79)/ .0338051618371416094D0/
+ DATA WGAUSS(80)/ .0320579283548515535D0/
+ DATA WGAUSS(81)/ .0302346570724024789D0/
+ DATA WGAUSS(82)/ .0283396726142594832D0/
+ DATA WGAUSS(83)/ .0263774697150546587D0/
+ DATA WGAUSS(84)/ .0243527025687108733D0/
+ DATA WGAUSS(85)/ .0222701738083832542D0/
+ DATA WGAUSS(86)/ .0201348231535302094D0/
+ DATA WGAUSS(87)/ .0179517157756973431D0/
+ DATA WGAUSS(88)/ .0157260304760247193D0/
+ DATA WGAUSS(89)/ .0134630478967186426D0/
+ DATA WGAUSS(90)/ .0111681394601311288D0/
+ DATA WGAUSS(91)/ .00884675982636394772D0/
+ DATA WGAUSS(92)/ .00650445796897836286D0/
+ DATA WGAUSS(93)/ .00414703326056246764D0/
+ DATA WGAUSS(94)/ .00178328072169643295D0/
+ DATA WGAUSS(95)/ .0486909570091397204D0/
+ DATA WGAUSS(96)/ .0485754674415034269D0/
+ DATA WGAUSS(97)/ .0483447622348029572D0/
+ DATA WGAUSS(98)/ .0479993885964583077D0/
+ DATA WGAUSS(99)/ .0475401657148303087D0/
+ DATA WGAUSS(100)/ .0469681828162100173D0/
+ DATA WGAUSS(101)/ .0462847965813144172D0/
+ DATA WGAUSS(102)/ .0454916279274181445D0/
+ DATA WGAUSS(103)/ .0445905581637565631D0/
+ DATA WGAUSS(104)/ .0435837245293234534D0/
+ DATA WGAUSS(105)/ .0424735151236535890D0/
+ DATA WGAUSS(106)/ .0412625632426235286D0/
+ DATA WGAUSS(107)/ .0399537411327203414D0/
+ DATA WGAUSS(108)/ .0385501531786156291D0/
+ DATA WGAUSS(109)/ .0370551285402400460D0/
+ DATA WGAUSS(110)/ .0354722132568823838D0/
+ DATA WGAUSS(111)/ .0338051618371416094D0/
+ DATA WGAUSS(112)/ .0320579283548515535D0/
+ DATA WGAUSS(113)/ .0302346570724024789D0/
+ DATA WGAUSS(114)/ .0283396726142594832D0/
+ DATA WGAUSS(115)/ .0263774697150546587D0/
+ DATA WGAUSS(116)/ .0243527025687108733D0/
+ DATA WGAUSS(117)/ .0222701738083832542D0/
+ DATA WGAUSS(118)/ .0201348231535302094D0/
+ DATA WGAUSS(119)/ .0179517157756973431D0/
+ DATA WGAUSS(120)/ .0157260304760247193D0/
+ DATA WGAUSS(121)/ .0134630478967186426D0/
+ DATA WGAUSS(122)/ .0111681394601311288D0/
+ DATA WGAUSS(123)/ .00884675982636394772D0/
+ DATA WGAUSS(124)/ .00650445796897836286D0/
+ DATA WGAUSS(125)/ .00414703326056246764D0/
+ DATA WGAUSS(126)/ .00178328072169643295D0/
+C
+ W1 = PGAM(4,1)
+ W2 = PGAM(4,2)
+ bmin = b1 - 2.D0*RADSRC(1)
+ IF (RADSRC(1) .GT. bmin) THEN
+ bmin = RADSRC(1)
+ ENDIF
+ bmax = b1 + 2.D0 * RADSRC(1)
+
+ XINT = 0.D0
+ DO 100 N=1,6
+ XINT2 = XINT
+ XINT = 0.D0
+ DO 200 I=2**N-1,2**(N+1)-2
+ b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
+ XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
+ & * PHO_GGFNUC(W2,b2,GAMSRC(2))
+ & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
+ XINT = XINT +WGAUSS(I) * b2 * XINT3
+ 200 CONTINUE
+ XINT = (bmax-bmin)/2.D0*XINT
+ IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
+ 100 CONTINUE
+ WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
+ 300 CONTINUE
+
+ PHO_GGFAUX = XINT
+
+ END
+
+*$ CREATE PHO_GGFNUC.FOR
+*COPY PHO_GGFNUC
+CDECK ID>, PHO_GGFNUC
+ DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
+C**********************************************************************
+C
+C differential photonnumber for a nucleus (geometrical model)
+C (without form factor)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0)
+
+ WGamma = W/Gamma
+ Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
+
+ PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
+
+ END
+
+*$ CREATE PHO_GHHIOF.FOR
+*COPY PHO_GHHIOF
+CDECK ID>, PHO_GHHIOF
+ SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-hadron collisions in heavy ion collisions
+C (form factor approach)
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX1,2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+ DIMENSION NITERS(2),ITRW(2)
+
+ WRITE(LO,'(2(/1X,A))')
+ & 'PHO_GHHIOF: gamma-hadron event generation',
+ & '-----------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+ AMP = 0.938D0
+ AMP2 = AMP**2
+C correct Q2MAX1,2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(2) = HIMASS
+C check cuts on photon-hadron mass
+ IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
+ YMI = ECMIN
+ ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
+ ENDIF
+C check kinematic limitations
+ YMI = ECMIN**2/(4.D0*EE*EEN)
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
+ & Q2MAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
+ & ECMAX
+ WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
+ & PARMDL(175)
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
+ CALL PHO_ABORT
+ ENDIF
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX1
+ YMIN = YMIN1
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 100 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
+ YMAX1 = MIN(Y1,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+C
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y1*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GHHIOF: integrated flux (one side):',FLUX
+C
+C photon
+ EGAM = MAX(YMAX1,YMAX2)*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,2212,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
+ WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+C
+ IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
+ IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
+C
+ FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
+ & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
+C
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ NITERS(1) = 0
+ NITERS(2) = 0
+ ITRY = 0
+ ITRW(1) = 0
+ ITRW(2) = 0
+ DO 200 I=1,NITER
+C sample y1, y2
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+C
+C select side of photon emission
+ IF(DT_RNDM(AY1).LT.FAC12) THEN
+ ITRW(1) = ITRW(1)+1
+C select Y1
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) GOTO 175
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
+ IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
+ IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y1)**2
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+C impact parameter
+ GAIMP(1) = 1.D0/SQRT(Q2P1)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
+C photon data
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EE**2-AMP2)
+ PINI(4,1) = EE
+ PINI(5,1) = AMP
+C outgoing hadron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P1)
+ Q2E = Q2P1/(4.D0*EE)
+ E1Y = EE*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+ PFPHI(1) = ATAN2(COF,SIF)
+ PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C scattering photon
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C scattering hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+ ISIDE = 1
+C
+ ELSE
+C
+ ITRW(2) = ITRW(2)+1
+C select Y2
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+ IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
+ IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
+C photon data
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EE**2-AMP2)
+ PINI(4,1) = EE
+ PINI(5,1) = AMP
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C scattering hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+C scattering photon
+ P1(1) = -PFIN(1,2)
+ P1(2) = -PFIN(2,2)
+ P1(3) = PINI(3,2)-PFIN(3,2)
+ P1(4) = PINI(4,2)-PFIN(4,2)
+ ISIDE = 2
+ ENDIF
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+ CALL PHO_PRESEL(5,IREJ)
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C user cuts
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+C cut on diffractive mass
+ DO 250 K=1,NHEP
+ IF(ISTHEP(K).EQ.30) THEN
+ GHDIFF = PHEP(1,K)
+ IF(GHDIFF.GE.PARMDL(175)) THEN
+ GOTO 251
+ ELSE
+ GOTO 150
+ ENDIF
+ ENDIF
+ 250 CONTINUE
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_GHHIOF: no diffractive entry found'
+ CALL PHO_PREVNT(-1)
+ GOTO 150
+ 251 CONTINUE
+C remove quasi-elastically scattered hadron
+ DO 260 K=1,NHEP
+ IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
+ XF = ABS(PHEP(3,K)/EEN)
+ IF(XF.LT.PARMDL(72)) GOTO 150
+* ISTHEP(K) = 2
+ GOTO 261
+ ENDIF
+ 260 CONTINUE
+ 261 CONTINUE
+C
+C statistics
+
+ NITERS(ISIDE) = NITERS(ISIDE)+1
+ IF(ISIDE.EQ.1) THEN
+
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ Q21AVE = Q21AVE+Q2P1
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY1MAX = MAX(YY1MAX,Y1)
+ ELSE
+
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q22AVE = Q22AVE+Q2P2
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY2MAX = MAX(YY2MAX,Y2)
+ ENDIF
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
+ WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
+ WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
+ AY1 = AY1/DBLE(MAX(NITERS(1),1))
+ AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
+ AY2 = AY2/DBLE(MAX(NITERS(2),1))
+ AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
+ Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
+ Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
+ Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
+ Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
+ WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,/3X,6I12)')
+ & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
+ & NITER,NITERS,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GHHIAS.FOR
+*COPY PHO_GHHIAS
+CDECK ID>, PHO_GHHIAS
+ SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-hadron collisions in heavy ion - hadron
+C collisions (form factor approach)
+C
+C input: EEP LAB system energy of proton (GeV)
+C EEN LAB system energy per nucleon (GeV)
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+ WRITE(LO,'(2(/1X,A))')
+ & 'PHO_GHHIAS: hadron-gamma event generation',
+ & '-----------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+ AMP = 0.938D0
+ AMP2 = AMP**2
+C correct Q2MAX2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(2) = GAMMA
+ RADSRC(2) = HIRADI
+ AMSRC(2) = HIMASS
+C check kinematic limitations
+ YMI = ECMIN**2/(4.D0*EE*EEP)
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
+ WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
+ & ECMAX
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+C
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
+ DO 105 I=1,Max_tab
+ Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
+ FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y2*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GHHIAS: integrated flux:',FLUX
+C
+C hadron
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = -SQRT(EEP**2-AMP2)
+ P1(4) = EEP
+C photon
+ EGAM = YMAX2*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,2212,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+C
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y2 = YMIN2
+ WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+C
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q22MIN = 1.D30
+ Q22MAX = 0.D0
+ Q22AVE = 0.D0
+ Q22AV2 = 0.D0
+ YY2MIN = 1.D30
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ NITERS = 0
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+C sample photon flux
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+C
+ ITRW = ITRW+1
+C select Y2
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+ IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
+ IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
+C photon data
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EEP**2-AMP2)
+ PINI(4,1) = EEP
+ PINI(5,1) = AMP
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C scattering hadron
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EEP**2-AMP2)
+ P1(4) = EEP
+ Q2P1 = AMP2
+C scattering photon
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+ ISIDE = 2
+C
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = AMP
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+C photon helicities
+ IGHEL(2) = 1
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+C cut on diffractive mass
+ DO 250 K=1,NHEP
+ IF(ISTHEP(K).EQ.30) THEN
+ GHDIFF = PHEP(1,K)
+ IF(GHDIFF.GE.PARMDL(175)) THEN
+ GOTO 251
+ ELSE
+ GOTO 150
+ ENDIF
+ ENDIF
+ 250 CONTINUE
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_GHHIOF: no diffractive entry found'
+ CALL PHO_PREVNT(-1)
+ GOTO 150
+ 251 CONTINUE
+C remove quasi-elastically scattered hadron
+ DO 260 K=1,NHEP
+ IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
+ XF = ABS(PHEP(3,K)/EEN)
+ IF(XF.LT.PARMDL(72)) GOTO 150
+* ISTHEP(K) = 2
+ GOTO 261
+ ENDIF
+ 260 CONTINUE
+ 261 CONTINUE
+C
+C statistics
+
+ NITERS = NITERS+1
+
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q22AVE = Q22AVE+Q2P2
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY2MAX = MAX(YY2MAX,Y2)
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
+ WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
+ AY2 = AY2/DBLE(MAX(NITERS,1))
+ AYS2 = AYS2/DBLE(MAX(NITERS,1))
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
+ Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
+ Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,/3X,4I12)')
+ & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
+ & NITER,NITERS,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_GHHIOF: no output of histograms',NITER
+ ENDIF
+
+ END
+
+*$ CREATE PHO_FITPAR.FOR
+*COPY PHO_FITPAR
+CDECK ID>, PHO_FITPAR
+ SUBROUTINE PHO_FITPAR(IOUTP)
+C**********************************************************************
+C
+C read input parameters according to PDFs
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEFA=-99999.D0,
+ & DEFB=-100000.D0,
+ & THOUS=1.D3)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+
+ DIMENSION INUM(3),IFPAS(2)
+ CHARACTER*8 CNAME8,PDFNA1,PDFNA2
+ CHARACTER*10 CNAM10
+
+ PARAMETER ( Max_tab = 22 )
+ DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
+ REAL XDPtab
+ INTEGER IDPtab
+
+C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 1),k=1,8) /
+ & 2212, 5, 6, 0, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 1),k=1,27) /
+ &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
+ &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
+ &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
+ &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
+ DATA (IDPtab(k, 2),k=1,8) /
+ & 2212, 5, 6, 0, -2212, 5, 6, 0 /
+ DATA (XDPtab(k, 2),k=1,27) /
+ &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
+ &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
+ &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
+ &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 3),k=1,8) /
+ & 22, 5, 3, 0, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 3),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
+ DATA (IDPtab(k, 4),k=1,8) /
+ & 22, 5, 3, 0, 22, 5, 3, 0 /
+ DATA (XDPtab(k, 4),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 5),k=1,8) /
+ & 22, 5, 4, 4, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 5),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
+ DATA (IDPtab(k, 6),k=1,8) /
+ & 22, 5, 4, 4, 22, 5, 4, 4 /
+ DATA (XDPtab(k, 6),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
+ DATA (IDPtab(k, 7),k=1,8) /
+ & 22, 1, 1, 4, 22, 1, 1, 4 /
+ DATA (XDPtab(k, 7),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
+ &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
+ DATA (IDPtab(k, 8),k=1,8) /
+ & 22, 1, 2, 4, 22, 1, 2, 4 /
+ DATA (XDPtab(k, 8),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
+ &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
+ DATA (IDPtab(k, 9),k=1,8) /
+ & 22, 1, 3, 4, 22, 1, 3, 4 /
+ DATA (XDPtab(k, 9),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
+ &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
+ DATA (IDPtab(k, 10),k=1,8) /
+ & 22, 1, 4, 4, 22, 1, 4, 4 /
+ DATA (XDPtab(k, 10),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
+ &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 11),k=1,8) /
+ & 22, 3, 1, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 11),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 12),k=1,8) /
+ & 22, 3, 1, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 12),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 13),k=1,8) /
+ & 22, 3, 1, 3, 22, 3, 1, 3 /
+ DATA (XDPtab(k, 13),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
+ &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 14),k=1,8) /
+ & 22, 3, 1, 2, 22, 3, 1, 2 /
+ DATA (XDPtab(k, 14),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
+ &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 15),k=1,8) /
+ & 22, 3, 2, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 15),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 16),k=1,8) /
+ & 22, 3, 2, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 16),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 17),k=1,8) /
+ & 22, 3, 2, 3, 22, 3, 2, 3 /
+ DATA (XDPtab(k, 17),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 18),k=1,8) /
+ & 22, 3, 2, 2, 22, 3, 2, 2 /
+ DATA (XDPtab(k, 18),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 19),k=1,8) /
+ & 22, 3, 3, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 19),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 20),k=1,8) /
+ & 22, 3, 3, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 20),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 21),k=1,8) /
+ & 22, 3, 3, 3, 22, 3, 3, 3 /
+ DATA (XDPtab(k, 21),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 22),k=1,8) /
+ & 22, 3, 3, 2, 22, 3, 3, 2 /
+ DATA (XDPtab(k, 22),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+ DATA CNAME8 /' '/
+ DATA CNAM10 /' '/
+ DATA INIT / 0 /
+ DATA IFPAS / 0, 0 /
+
+ IF((INIT.EQ.1).AND.
+ & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
+
+ INIT=1
+ IFPAS(1) = IFPAP(1)
+ IFPAS(2) = IFPAP(2)
+
+C parton distribution functions
+ CALL PHO_ACTPDF(IFPAP(1),1)
+ CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
+ CALL PHO_ACTPDF(IFPAP(2),2)
+ CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+
+ IF(IDEB(54).GE.0) THEN
+ WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
+ & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
+ WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
+ & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
+ ENDIF
+
+ IFOUND = 0
+
+C load parameter set from internal tables
+ I1 = 1
+ I2 = 2
+ 110 CONTINUE
+
+ DO I=1,Max_tab
+ IF((IFPAP(I1).EQ.IDPtab(1,I))
+ & .AND.(IGRP(I1).EQ.IDPtab(2,I))
+ & .AND.(ISET(I1).EQ.IDPtab(3,I))
+ & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
+ IF((IFPAP(I2).EQ.IDPtab(5,I))
+ & .AND.(IGRP(I2).EQ.IDPtab(6,I))
+ & .AND.(ISET(I2).EQ.IDPtab(7,I))
+ & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_FITPAR: parameter set found in internal table'
+ ALPOM = XDPtab(1,I)
+ ALPOMP = XDPtab(2,I)
+ GP(I1) = XDPtab(3,I)
+ GP(I2) = XDPtab(4,I)
+ B0POM(I1) = XDPtab(5,I)
+ B0POM(I2) = XDPtab(6,I)
+ ALREG = XDPtab(7,I)
+ ALREGP = XDPtab(8,I)
+ GR(I1) = XDPtab(9,I)
+ GR(I2) = XDPtab(10,I)
+ B0REG(I1) = XDPtab(11,I)
+ B0REG(I2) = XDPtab(12,I)
+ GPPP = XDPtab(13,I)
+ B0PPP = XDPtab(14,I)
+ GPPR = XDPtab(15,I)
+ B0PPR = XDPtab(16,I)
+ VDMFAC(2*I1-1) = XDPtab(17,I)
+ VDMFAC(2*I1) = XDPtab(18,I)
+ VDMFAC(2*I2-1) = XDPtab(19,I)
+ VDMFAC(2*I2) = XDPtab(20,I)
+ B0HAR = XDPtab(21,I)
+ AKFAC = XDPtab(22,I)
+ PHISUP(I1) = XDPtab(23,I)
+ PHISUP(I2) = XDPtab(24,I)
+ RMASS(I1) = XDPtab(25,I)
+ RMASS(I2) = XDPtab(26,I)
+ VAR = XDPtab(27,I)
+ IFOUND = 1
+ GOTO 1200
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF(I1.EQ.1) THEN
+ I1 = 2
+ I2 = 1
+ GOTO 110
+ ELSE
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_FITPAR: parameter set not found in internal table'
+ ENDIF
+
+ 1200 CONTINUE
+
+C get parameters of soft cross sections from fitpar.dat
+ IF(IPAMDL(99).GT.IFOUND) THEN
+
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
+ OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
+
+ 100 CONTINUE
+ READ(12,'(A8)',ERR=1020,END=1010) CNAME8
+ IF(CNAME8.EQ.'STOP') GOTO 1010
+ IF(CNAME8.EQ.'NEXTDATA') THEN
+ READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
+ & IDPA1,CNAME8,INUM
+ IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
+ & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
+ READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
+ & IDPA2,CNAME8,INUM
+ IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
+ & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
+ READ(12,*) ALPOM,ALPOMP,GP,B0POM
+ READ(12,*) ALREG,ALREGP,GR,B0REG
+ READ(12,*) GPPP,B0PPP,GPPR,B0PPR
+ READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
+ READ(12,*) B0HAR
+ READ(12,*) AKFAC
+ READ(12,*) PHISUP
+ READ(12,*) RMASS,VAR
+ IFOUND = 1
+ GOTO 1100
+ ENDIF
+ ENDIF
+ ENDIF
+ GOTO 100
+
+ 1020 CONTINUE
+ WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
+ WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
+ 1010 CONTINUE
+ WRITE(LO,'(/A)')
+ & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
+
+ 1100 CONTINUE
+ CLOSE(12)
+
+ ENDIF
+
+C nothing found
+ IF(IFOUND.EQ.0) THEN
+ WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
+ WRITE(LO,'(3(10X,A,/))')
+ & '(copy fitpar.dat into the working directory and/or',
+ & ' request the missing parameter set via e-mail from',
+ & ' ralph.engel@fzk.de)'
+ STOP
+ ENDIF
+
+ 1300 CONTINUE
+
+C overwrite parameters with user settings
+ IF(PARMDL(301).GT.DEFA) THEN
+ ALPOM = PARMDL(301)
+ PARMDL(301) = DEFB
+ ENDIF
+ IF(PARMDL(302).GT.DEFA) THEN
+ ALPOMP = PARMDL(302)
+ PARMDL(302) = DEFB
+ ENDIF
+ IF(PARMDL(303).GT.DEFA) THEN
+ GP(1) = PARMDL(303)
+ PARMDL(303) = DEFB
+ ENDIF
+ IF(PARMDL(304).GT.DEFA) THEN
+ GP(2) = PARMDL(304)
+ PARMDL(304) = DEFB
+ ENDIF
+ IF(PARMDL(305).GT.DEFA) THEN
+ B0POM(1) = PARMDL(305)
+ PARMDL(305) = DEFB
+ ENDIF
+ IF(PARMDL(306).GT.DEFA) THEN
+ B0POM(2) = PARMDL(306)
+ PARMDL(306) = DEFB
+ ENDIF
+ IF(PARMDL(307).GT.DEFA) THEN
+ ALREG = PARMDL(307)
+ PARMDL(307) = DEFB
+ ENDIF
+ IF(PARMDL(308).GT.DEFA) THEN
+ ALREGP = PARMDL(308)
+ PARMDL(308) = DEFB
+ ENDIF
+ IF(PARMDL(309).GT.DEFA) THEN
+ GR(1) = PARMDL(309)
+ PARMDL(309) = DEFB
+ ENDIF
+ IF(PARMDL(310).GT.DEFA) THEN
+ GR(2) = PARMDL(310)
+ PARMDL(310) = DEFB
+ ENDIF
+ IF(PARMDL(311).GT.DEFA) THEN
+ B0REG(1) = PARMDL(311)
+ PARMDL(311) = DEFB
+ ENDIF
+ IF(PARMDL(312).GT.DEFA) THEN
+ B0REG(2) = PARMDL(312)
+ PARMDL(312) = DEFB
+ ENDIF
+ IF(PARMDL(313).GT.DEFA) THEN
+ GPPP = PARMDL(313)
+ PARMDL(313) = DEFB
+ ENDIF
+ IF(PARMDL(314).GT.DEFA) THEN
+ B0PPP = PARMDL(314)
+ PARMDL(314)= DEFB
+ ENDIF
+ IF(PARMDL(315).GT.DEFA) THEN
+ VDMFAC(1) = PARMDL(315)
+ PARMDL(315)= DEFB
+ ENDIF
+ IF(PARMDL(316).GT.DEFA) THEN
+ VDMFAC(2) = PARMDL(316)
+ PARMDL(316)= DEFB
+ ENDIF
+ IF(PARMDL(317).GT.DEFA) THEN
+ VDMFAC(3) = PARMDL(317)
+ PARMDL(317)= DEFB
+ ENDIF
+ IF(PARMDL(318).GT.DEFA) THEN
+ VDMFAC(4) = PARMDL(318)
+ PARMDL(318)= DEFB
+ ENDIF
+ IF(PARMDL(319).GT.DEFA) THEN
+ B0HAR = PARMDL(319)
+ PARMDL(319)= DEFB
+ ENDIF
+ IF(PARMDL(320).GT.DEFA) THEN
+ AKFAC = PARMDL(320)
+ PARMDL(320)= DEFB
+ ENDIF
+ IF(PARMDL(321).GT.DEFA) THEN
+ PHISUP(1) = PARMDL(321)
+ PARMDL(321)= DEFB
+ ENDIF
+ IF(PARMDL(322).GT.DEFA) THEN
+ PHISUP(2) = PARMDL(322)
+ PARMDL(322)= DEFB
+ ENDIF
+ IF(PARMDL(323).GT.DEFA) THEN
+ RMASS(1) = PARMDL(323)
+ PARMDL(323)= DEFB
+ ENDIF
+ IF(PARMDL(324).GT.DEFA) THEN
+ RMASS(2) = PARMDL(324)
+ PARMDL(324)= DEFB
+ ENDIF
+ IF(PARMDL(325).GT.DEFA) THEN
+ VAR = PARMDL(325)
+ PARMDL(325)= DEFB
+ ENDIF
+ IF(PARMDL(327).GT.DEFA) THEN
+ GPPR = PARMDL(327)
+ PARMDL(327)= DEFB
+ ENDIF
+ IF(PARMDL(328).GT.DEFA) THEN
+ B0PPR = PARMDL(328)
+ PARMDL(328)= DEFB
+ ENDIF
+
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = VDMFAC(3)
+ VDMQ2F(4) = VDMFAC(4)
+
+C output of parameter set
+ IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
+ WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
+ & ' -------------------------'
+ WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
+ & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
+ & B0POM
+ WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
+ & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
+ & B0REG
+ WRITE(LO,'(4(A,F7.3))')
+ & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
+ WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
+ WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
+ WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
+ WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
+ WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
+ WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
+ ENDIF
+
+ CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
+
+ END
+
+*$ CREATE PHO_BORNCS.FOR
+*COPY PHO_BORNCS
+CDECK ID>, PHO_BORNCS
+ SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
+C*********************************************************************
+C
+C calculation of Born graph cross sections and slopes
+C
+C input: IP particle combination
+C IFHARD -1 calculate hard Born graph cross section
+C 0 take hard Born graph cross section
+C from interpolation table if available
+C 1 assume that correct hard cross
+C sections are already stored in /POSBRN/
+C XM1,XM2,XM3,XM4 masses of external lines
+C /GLOCMS/ energy and PT cut-off
+C /POPREG/ soft and hard parameters
+C /POSBRN/ input cross sections
+C /POZBRN/ scaled input values
+C IFHARD 0 calculate hard input cross sections
+C 1 assume hard input cross sections exist
+C
+C output: ZPOM scaled pomeron cross section
+C ZIGR scaled reggeon cross section
+C ZIGHR scaled hard resolved cross section
+C ZIGHD scaled hard direct cross section
+C ZIGT1 scaled triple-Pomeron cross section
+C ZIGT2 scaled triple-Pomeron cross section
+C ZIGL scaled loop-Pomeron cross section
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & IFOUR=4,
+ & IFIVE=5,
+ & FIVE=5.D0,
+ & THOUS=1.D3,
+ & EPS=0.01D0,
+ & DEPS=1.D-30)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C scaled cross sections and slopes
+ COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
+ & ZIGD1,ZIGD2,
+ & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
+ COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
+ & ZIGDP(4),ZIGD1(2),ZIGD2(2),
+ & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
+ & BD1(2),BD2(2)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
+ & BPOM1,BPOM2,BREG1,BREG2,B0HARD
+ DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
+ DIMENSION BT14(2),BT24(2),BD4(4)
+ DIMENSION DSPT(0:Max_pro_2)
+
+ DATA XMPOM / 0.766D0 /
+ DATA CZERO /(0.D0,0.D0)/
+
+ CDABS(SS) = ABS(SS)
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+C debug output
+ IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
+ & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
+C scales
+ CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
+C
+C calculate hard input cross sections (output in mb)
+ IF(IFHARD.NE.1) THEN
+ IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
+C double-log interpolation
+ CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
+ DO 60 M=0,Max_pro_2
+ DSIGH(M) = HSig(M)
+ DSPT(M) = Hdpt(M)
+ 60 CONTINUE
+ ELSE
+C new calculation
+ CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
+ CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
+ ENDIF
+C
+C save values to calculate soft pt distribution
+ IF(IP.EQ.1) THEN
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = VDMFAC(3)
+ VDMQ2F(4) = VDMFAC(4)
+ ELSE IF(IP.EQ.2) THEN
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ELSE IF(IP.EQ.3) THEN
+ VDMQ2F(1) = VDMFAC(3)
+ VDMQ2F(2) = VDMFAC(4)
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ELSE
+ VDMQ2F(1) = 1.D0
+ VDMQ2F(2) = 0.D0
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ENDIF
+C VDM factors
+ AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
+ AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
+ AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
+ AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
+ ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
+ & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
+ ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
+ ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
+ ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
+ VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
+ & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
+ DSIGHP = DSPT(9)/VFAC
+ SIGH = DSIGH(9)/VFAC
+C extract real part
+ IF(IPAMDL(1).EQ.0) THEN
+ DO 50 I=0,Max_pro_2
+ DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
+ 50 CONTINUE
+ ENDIF
+C write out results
+ IF(IDEB(48).GE.15) THEN
+ WRITE(LO,'(/1X,A,1P,2E11.3)')
+ & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
+ DO 200 I=0,Max_pro_2
+ WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
+ 200 CONTINUE
+ ENDIF
+ ENDIF
+
+C DPMJET interface: subtract anomalous part
+ IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
+ & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
+
+ SCALE = CDABS(DSIGH(15))
+ IF(SCALE.LT.DEPS) THEN
+ SIGHD=CZERO
+ ELSE
+ SIGHD=DSIGH(15)
+ ENDIF
+ SCALE = CDABS(DSIGH(9))
+ IF(SCALE.LT.DEPS) THEN
+ SIGHR=CZERO
+ ELSE
+ SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
+ ENDIF
+
+C calculate soft input cross sections (output in mb)
+ SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
+ IF(IPAMDL(1).EQ.1) THEN
+C pomeron signature
+ SP=SS*DCMPLX(0.D0,-1.D0)
+C reggeon signature
+ SR=SS*DCMPLX(0.D0,1.D0)
+ ELSE
+ SP=SS
+ SR=SS
+ ENDIF
+C coupling constants (mb**1/2)
+C particle dependent slopes (GeV**-2)
+ IF(IP.EQ.1) THEN
+ GP1 = GP(1)
+ GP2 = GP(2)
+ GR1 = GR(1)
+ GR2 = GR(2)
+ B0POM1 = B0POM(1)
+ B0POM2 = B0POM(2)
+ B0REG1 = B0REG(1)
+ B0REG2 = B0REG(2)
+ B0HARD = B0HAR
+ RMASS1 = RMASS(1)
+ RMASS2 = RMASS(2)
+ ELSE IF(IP.EQ.2) THEN
+ GP1 = GP(1)
+ GP2 = PARMDL(77)
+ GR1 = GR(1)
+ GR2 = PARMDL(77)*GPPR/GPPP
+ B0POM1 = B0POM(1)
+ B0POM2 = B0PPP
+ B0REG1 = B0REG(1)
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = RMASS(1)
+ RMASS2 = XMPOM
+ ELSE IF(IP.EQ.3) THEN
+ GP1 = GP(2)
+ GP2 = PARMDL(77)
+ GR1 = GR(2)
+ GR2 = PARMDL(77)*GPPR/GPPP
+ B0POM1 = B0POM(2)
+ B0POM2 = B0PPP
+ B0REG1 = B0REG(2)
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = RMASS(2)
+ RMASS2 = XMPOM
+ ELSE IF(IP.EQ.4) THEN
+ GP1 = PARMDL(77)
+ GP2 = GP1
+ GR1 = PARMDL(77)*GPPR/GPPP
+ GR2 = GR1
+ B0POM1 = B0PPP
+ B0POM2 = B0PPP
+ B0REG1 = B0PPR
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = XMPOM
+ RMASS2 = XMPOM
+ ELSE
+ WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
+ CALL PHO_ABORT
+ ENDIF
+ GP1 = GP1*SCALE1
+ GP2 = GP2*SCALE2
+ GR1 = GR1*SCALE1
+ GR2 = GR2*SCALE2
+C input slope parameters (GeV**-2)
+ BPOM1 = B0POM1*SCALB1
+ BPOM2 = B0POM2*SCALB2
+ BREG1 = B0REG1*SCALB1
+ BREG2 = B0REG2*SCALB2
+C effective slopes
+ XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
+ SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
+ BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
+ BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
+ IF(IPAMDL(9).EQ.0) THEN
+ BHAR = B0HARD
+ BHAD = B0HARD
+ ELSE IF(IPAMDL(9).EQ.1) THEN
+ BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
+ BHAD = BHAR
+ ELSE IF(IPAMDL(9).EQ.2) THEN
+ BHAR = BPOM1+BPOM2
+ BHAD = BHAR
+ ELSE
+ BHAR = BPOM
+ BHAD = BPOM
+ ENDIF
+C input cross section pomeron
+ SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
+ SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
+C save value to calculate soft pt distribution
+ SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
+
+C higher order graphs
+ VIRT1 = PVIRTP(1)
+ VIRT2 = PVIRTP(2)
+C bare/renormalized intercept for enhanced graphs
+ IF(IPAMDL(8).EQ.0) THEN
+ DELTAP = ALPOM-1.D0
+ ELSE
+ DELTAP = PARMDL(48)-1.D0
+ ENDIF
+ SD = ECMP**2
+ BP1 = 2.D0*BPOM1
+ BP2 = 2.D0*BPOM2
+C input cross section high-mass double diffraction
+ CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
+ SIGL = DCMPLX(SIGTR,0.D0)
+ BLOO = DCMPLX(BTR,0.D0)
+C
+C input cross section high mass diffraction particle 1
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
+ SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
+ BTR1(1) = DCMPLX(BTR,0.D0)
+C second possibility: high-low mass double diffraction
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
+ SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
+ BTR1(2) = DCMPLX(BTR,0.D0)
+C
+C input cross section high mass diffraction particle 2
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
+ SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
+ BTR2(1) = DCMPLX(BTR,0.D0)
+C second possibility: high-low mass double diffraction
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
+ SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
+ BTR2(2) = DCMPLX(BTR,0.D0)
+C
+C input cross section for loop-pomeron
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(1) = DCMPLX(BTX,0.D0)
+C second possibility
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(2) = DCMPLX(BTX,0.D0)
+C third possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(3) = DCMPLX(BTX,0.D0)
+C fourth possibility
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(4) = DCMPLX(BTX,0.D0)
+C
+C input cross section for YY-iterated triple-pomeron
+C .....
+C
+C write out input cross sections
+ IF(IDEB(48).GE.5) THEN
+ WRITE(LO,'(2(/1X,A))')
+ & 'Born graph input cross sections and slopes',
+ & '------------------------------------------'
+ WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
+ WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
+ & XM1,XM2,XM3,XM4
+ WRITE(LO,'(A)') ' input cross sections (millibarn):'
+ WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
+ WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
+ WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
+ WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
+ WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
+ WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
+ WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
+ WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
+ WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
+ WRITE(LO,'(A)') ' input slopes (GeV**-2)'
+ WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
+ WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
+ WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
+ WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
+ WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
+ WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
+ WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
+ WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
+ WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
+ WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
+ WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
+ WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
+ WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
+ WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
+ ENDIF
+C
+ BPOM = BPOM*GEV2MB
+ BREG = BREG*GEV2MB
+ BHAR = BHAR*GEV2MB
+ BHAD = BHAD*GEV2MB
+ BTR1(1) = BTR1(1)*GEV2MB
+ BTR1(2) = BTR1(2)*GEV2MB
+ BTR2(1) = BTR2(1)*GEV2MB
+ BTR2(2) = BTR2(2)*GEV2MB
+ BLOO = BLOO*GEV2MB
+C
+ BP4 =BPOM*4.D0
+ BR4 =BREG*4.D0
+ BHR4=BHAR*4.D0
+ BHD4=BHAD*4.D0
+ BT14(1)=BTR1(1)*4.D0
+ BT14(2)=BTR1(2)*4.D0
+ BT24(1)=BTR2(1)*4.D0
+ BT24(2)=BTR2(2)*4.D0
+ BL4 =BLOO*4.D0
+C
+ ZIGP = SIGP/(PI2*BP4)
+ ZIGR = SIGR/(PI2*BR4)
+ ZIGHR = SIGHR/(PI2*BHR4)
+ ZIGHD = SIGHD/(PI2*BHD4)
+ ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
+ ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
+ ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
+ ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
+ ZIGL = SIGL/(PI2*BL4)
+ DO 20 I=1,4
+ BDP(I) = BDP(I)*GEV2MB
+ BD4(I) = BDP(I)*4.D0
+ ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
+ 20 CONTINUE
+C
+ IF(IDEB(48).GE.10) THEN
+ WRITE(LO,'(A)') ' normalized input values:'
+ WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
+ WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
+ WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
+ WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
+ WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
+ WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
+ WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
+ WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
+ WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
+ WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
+ WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
+ WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
+ WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
+ ENDIF
+ END
+
+*$ CREATE PHO_SCALES.FOR
+*COPY PHO_SCALES
+CDECK ID>, PHO_SCALES
+ SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
+C**********************************************************************
+C
+C calculation of scale factors
+C (mass dependent couplings and slopes)
+C
+C input: XM1..XM4 external masses
+C
+C output: SCG1,SCG2 scales of coupling constants
+C SCB1,SCB2 scales of coupling slope parameter
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-3 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C scale factors for couplings
+ ECMMIN = 2.D0
+* ECMTP = 6.D0
+ ECMTP = 1.D0
+ IF(ABS(XM1-XM3).GT.EPS) THEN
+ IF(ECMP.LT.ECMTP) THEN
+ SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
+ ELSE
+ SCG1 = PHISUP(1)
+ ENDIF
+ ELSE
+ SCG1 = 1.D0
+ ENDIF
+ IF(ABS(XM2-XM4).GT.EPS) THEN
+ IF(ECMP.LT.ECMTP) THEN
+ SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
+ ELSE
+ SCG2 = PHISUP(2)
+ ENDIF
+ ELSE
+ SCG2 = 1.D0
+ ENDIF
+C
+C scale factors for slope parameters
+ IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
+ SCB1 = 1.D0
+ SCB2 = 1.D0
+ ELSE IF(ISWMDL(1).EQ.2) THEN
+C rational
+ SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
+ SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
+ ELSE IF(ISWMDL(1).GE.3) THEN
+C symmetric gaussian
+ SCB1 = VAR*(XM1-XM3)**2
+ IF(SCB1.LT.25.D0) THEN
+ SCB1 = EXP(-SCB1)
+ ELSE
+ SCB1 = 0.D0
+ ENDIF
+ SCB2 = VAR*(XM2-XM4)**2
+ IF(SCB2.LT.25.D0) THEN
+ SCB2 = EXP(-SCB2)
+ ELSE
+ SCB2 = 0.D0
+ ENDIF
+ ELSE
+ WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
+ & ISWMDL(1)
+ CALL PHO_ABORT
+ ENDIF
+C debug output
+ IF(IDEB(65).GE.10) THEN
+ WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
+ & XM1,XM2,XM3,XM4
+ WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
+ & SCB1,SCB2,SCG1,SCG2
+ ENDIF
+ END
+
+*$ CREATE PHO_EIKON.FOR
+*COPY PHO_EIKON
+CDECK ID>, PHO_EIKON
+ SUBROUTINE PHO_EIKON(IP,IFHARD,B)
+C*********************************************************************
+C
+C calculation of unitarized amplitudes
+C
+C input: IP particle combination
+C IFHARD -1 ignore previously calculated Born
+C cross sections
+C 0 calculate hard Born cross sections or
+C take them from interpolation table
+C (if available)
+C 1 take hard cross sections from /POSBRN/
+C B impact parameter (mb**(1/2))
+C /POSBRN/ input cross sections
+C /GLOCMS/ cm energy
+C /POPREG/ soft and hard parameters
+C
+C output: /POINT4/
+C AMPEL purely elastic amplitude
+C AMPVM quasi-elastically vectormeson prod.
+C AMLMSD(2) amplitudes of low mass sing. diffr.
+C AMHMSD(2) amplitudes of high mass sing. diffr.
+C AMLMDD amplitude of low mass double diffr.
+C AMHMDD amplitude of high mass double diffr.
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & IFOUR=4,
+ & IFIVE=5,
+ & ISIX=6,
+ & FIVE=5.D0,
+ & THOUS=1.D3,
+ & EXPMAX=70.D0,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C scaled cross sections and slopes
+ COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
+ & ZIGD1,ZIGD2,
+ & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
+ COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
+ & ZIGDP(4),ZIGD1(2),ZIGD2(2),
+ & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
+ & BD1(2),BD2(2)
+C Born graph cross sections after applying diffraction model
+ DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
+ & SBOLPO,SBODPO
+ COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
+ & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
+ & SBODPO(0:4,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+
+ COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
+ & AUXL,AMPR,AMPO,AMPP,AMPQ
+
+ DIMENSION PVOLD(2)
+
+ DATA ELAST / 0.D0 /
+ DATA IPOLD / -1 /
+ DATA PVOLD / -1.D0, -1.D0 /
+ DATA XMPOM / 0.766D0 /
+ DATA XMVDM / 0.766D0 /
+
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+C calculation of scaled cross sections and slopes
+
+C test for redundant calculation
+ IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
+ & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
+C effective particle masses, VDM assumption
+ XMASS1 = PMASS(1)
+ XMASS2 = PMASS(2)
+ RMASS1 = RMASS(1)
+ RMASS2 = RMASS(2)
+ IF(IFPAP(1).EQ.22) THEN
+ XMASS1 = XMVDM
+ ELSE IF(IFPAP(1).EQ.990) THEN
+ XMASS1 = XMPOM
+ ENDIF
+ IF(IFPAP(2).EQ.22) THEN
+ XMASS2 = XMVDM
+ ELSE IF(IFPAP(2).EQ.990) THEN
+ XMASS2 = XMPOM
+ ENDIF
+C different particle combinations
+ IF(IP.EQ.3) THEN
+ XMASS1 = XMASS2
+ RMASS1 = RMASS2
+ ELSE IF(IP.EQ.4) THEN
+ XMASS1 = XMPOM
+ RMASS1 = XMASS1
+ ENDIF
+ IF(IP.GT.1) THEN
+ XMASS2 = XMPOM
+ RMASS2 = XMASS2
+ ENDIF
+C update pomeron CM system
+ PMASSP(1) = XMASS1
+ PMASSP(2) = XMASS2
+ ECMP = ECM
+
+ CZERO = DCMPLX(0.D0,0.D0)
+ CONE = DCMPLX(1.D0,0.D0)
+ ELAST = ECM
+ PVOLD(1) = PVIRT(1)
+ PVOLD(2) = PVIRT(2)
+ IPOLD = IP
+
+C purely elastic scattering
+ CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
+ ZXP(1,1) = ZIGP
+ BXP(1,1) = BPOM
+ ZXR(1,1) = ZIGR
+ BXR(1,1) = BREG
+ ZXH(1,1) = ZIGHR
+ BXH(1,1) = BHAR
+ ZXD(1,1) = ZIGHD
+ BXD(1,1) = BHAD
+ ZXT1A(1,1) = ZIGT1(1)
+ BXT1A(1,1) = BTR1(1)
+ ZXT1B(1,1) = ZIGT1(2)
+ BXT1B(1,1) = BTR1(2)
+ ZXT2A(1,1) = ZIGT2(1)
+ BXT2A(1,1) = BTR2(1)
+ ZXT2B(1,1) = ZIGT2(2)
+ BXT2B(1,1) = BTR2(2)
+ ZXL(1,1) = ZIGL
+ BXL(1,1) = BLOO
+ ZXDPE(1,1) = ZIGDP(1)
+ BXDPE(1,1) = BDP(1)
+ ZXDPA(1,1) = ZIGDP(2)
+ BXDPA(1,1) = BDP(2)
+ ZXDPB(1,1) = ZIGDP(3)
+ BXDPB(1,1) = BDP(3)
+ ZXDPD(1,1) = ZIGDP(4)
+ BXDPD(1,1) = BDP(4)
+ SBOPOM(1) = SIGP
+ SBOREG(1) = SIGR
+ SBOHAR(1) = SIGHR
+ SBOHAD(1) = SIGHD
+ SBOTR1(1,1) = SIGT1(1)
+ SBOTR1(1,2) = SIGT1(2)
+ SBOTR2(1,1) = SIGT2(1)
+ SBOTR2(1,2) = SIGT2(2)
+ SBOLPO(1) = SIGL
+ SBODPO(1,1) = SIGDP(1)
+ SBODPO(1,2) = SIGDP(2)
+ SBODPO(1,3) = SIGDP(3)
+ SBODPO(1,4) = SIGDP(4)
+
+C low mass single diffractive scattering 1
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
+ ZXP(1,2) = ZIGP
+ BXP(1,2) = BPOM
+ ZXR(1,2) = ZIGR
+ BXR(1,2) = BREG
+ ZXH(1,2) = ZIGHR
+ BXH(1,2) = BHAR
+ ZXD(1,2) = ZIGHD
+ BXD(1,2) = BHAD
+ ZXT1A(1,2) = ZIGT1(1)
+ BXT1A(1,2) = BTR1(1)
+ ZXT1B(1,2) = ZIGT1(2)
+ BXT1B(1,2) = BTR1(2)
+ ZXT2A(1,2) = ZIGT2(1)
+ BXT2A(1,2) = BTR2(1)
+ ZXT2B(1,2) = ZIGT2(2)
+ BXT2B(1,2) = BTR2(2)
+ ZXL(1,2) = ZIGL
+ BXL(1,2) = BLOO
+ ZXDPE(1,2) = ZIGDP(1)
+ BXDPE(1,2) = BDP(1)
+ ZXDPA(1,2) = ZIGDP(2)
+ BXDPA(1,2) = BDP(2)
+ ZXDPB(1,2) = ZIGDP(3)
+ BXDPB(1,2) = BDP(3)
+ ZXDPD(1,2) = ZIGDP(4)
+ BXDPD(1,2) = BDP(4)
+ SBOPOM(2) = SIGP
+ SBOREG(2) = SIGR
+ SBOHAR(2) = SIGHR
+ SBOHAD(2) = 0.D0
+ SBOTR1(2,1) = SIGT1(1)
+ SBOTR1(2,2) = SIGT1(2)
+ SBOTR2(2,1) = SIGT2(1)
+ SBOTR2(2,2) = SIGT2(2)
+ SBOLPO(2) = SIGL
+ SBODPO(2,1) = SIGDP(1)
+ SBODPO(2,2) = SIGDP(2)
+ SBODPO(2,3) = SIGDP(3)
+ SBODPO(2,4) = SIGDP(4)
+
+C low mass single diffractive scattering 2
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
+ ZXP(1,3) = ZIGP
+ BXP(1,3) = BPOM
+ ZXR(1,3) = ZIGR
+ BXR(1,3) = BREG
+ ZXH(1,3) = ZIGHR
+ BXH(1,3) = BHAR
+ ZXD(1,3) = ZIGHD
+ BXD(1,3) = BHAD
+ ZXT1A(1,3) = ZIGT1(1)
+ BXT1A(1,3) = BTR1(1)
+ ZXT1B(1,3) = ZIGT1(2)
+ BXT1B(1,3) = BTR1(2)
+ ZXT2A(1,3) = ZIGT2(1)
+ BXT2A(1,3) = BTR2(1)
+ ZXT2B(1,3) = ZIGT2(2)
+ BXT2B(1,3) = BTR2(2)
+ ZXL(1,3) = ZIGL
+ BXL(1,3) = BLOO
+ ZXDPE(1,3) = ZIGDP(1)
+ BXDPE(1,3) = BDP(1)
+ ZXDPA(1,3) = ZIGDP(2)
+ BXDPA(1,3) = BDP(2)
+ ZXDPB(1,3) = ZIGDP(3)
+ BXDPB(1,3) = BDP(3)
+ ZXDPD(1,3) = ZIGDP(4)
+ BXDPD(1,3) = BDP(4)
+ SBOPOM(3) = SIGP
+ SBOREG(3) = SIGR
+ SBOHAR(3) = SIGHR
+ SBOHAD(3) = 0.D0
+ SBOTR1(3,1) = SIGT1(1)
+ SBOTR1(3,2) = SIGT1(2)
+ SBOTR2(3,1) = SIGT2(1)
+ SBOTR2(3,2) = SIGT2(2)
+ SBOLPO(3) = SIGL
+ SBODPO(3,1) = SIGDP(1)
+ SBODPO(3,2) = SIGDP(2)
+ SBODPO(3,3) = SIGDP(3)
+ SBODPO(3,4) = SIGDP(4)
+
+C low mass double diffractive scattering
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
+ ZXP(1,4) = ZIGP
+ BXP(1,4) = BPOM
+ ZXR(1,4) = ZIGR
+ BXR(1,4) = BREG
+ ZXH(1,4) = ZIGHR
+ BXH(1,4) = BHAR
+ ZXD(1,4) = ZIGHD
+ BXD(1,4) = BHAD
+ ZXT1A(1,4) = ZIGT1(1)
+ BXT1A(1,4) = BTR1(1)
+ ZXT1B(1,4) = ZIGT1(2)
+ BXT1B(1,4) = BTR1(2)
+ ZXT2A(1,4) = ZIGT2(1)
+ BXT2A(1,4) = BTR2(1)
+ ZXT2B(1,4) = ZIGT2(2)
+ BXT2B(1,4) = BTR2(2)
+ ZXL(1,4) = ZIGL
+ BXL(1,4) = BLOO
+ ZXDPE(1,4) = ZIGDP(1)
+ BXDPE(1,4) = BDP(1)
+ ZXDPA(1,4) = ZIGDP(2)
+ BXDPA(1,4) = BDP(2)
+ ZXDPB(1,4) = ZIGDP(3)
+ BXDPB(1,4) = BDP(3)
+ ZXDPD(1,4) = ZIGDP(4)
+ BXDPD(1,4) = BDP(4)
+ SBOPOM(4) = SIGP
+ SBOREG(4) = SIGR
+ SBOHAR(4) = SIGHR
+ SBOHAD(4) = 0.D0
+ SBOTR1(4,1) = SIGT1(1)
+ SBOTR1(4,2) = SIGT1(2)
+ SBOTR2(4,1) = SIGT2(1)
+ SBOTR2(4,2) = SIGT2(2)
+ SBOLPO(4) = SIGL
+ SBODPO(4,1) = SIGDP(1)
+ SBODPO(4,2) = SIGDP(2)
+ SBODPO(4,3) = SIGDP(3)
+ SBODPO(4,4) = SIGDP(4)
+
+C calculate Born graph cross sections
+ SBOPOM(0) = 0.D0
+ SBOREG(0) = 0.D0
+ SBOHAR(0) = 0.D0
+ SBOHAD(0) = 0.D0
+ SBOTR1(0,1) = 0.D0
+ SBOTR1(0,2) = 0.D0
+ SBOTR2(0,1) = 0.D0
+ SBOTR2(0,2) = 0.D0
+ SBOLPO(0) = 0.D0
+ SBODPO(0,1) = 0.D0
+ SBODPO(0,2) = 0.D0
+ SBODPO(0,3) = 0.D0
+ SBODPO(0,4) = 0.D0
+ DO 150 I=1,4
+ SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
+ SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
+ SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
+ SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
+ SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
+ SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
+ SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
+ SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
+ SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
+ SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
+ SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
+ SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
+ SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
+ 150 CONTINUE
+
+ SIGPOM = SBOPOM(0)
+ SIGREG = SBOREG(0)
+ SIGTR1(1) = SBOTR1(0,1)
+ SIGTR1(2) = SBOTR1(0,2)
+ SIGTR2(1) = SBOTR2(0,1)
+ SIGTR2(2) = SBOTR2(0,2)
+ SIGLOO = SBOLPO(0)
+ SIGDPO(1) = SBODPO(0,1)
+ SIGDPO(2) = SBODPO(0,2)
+ SIGDPO(3) = SBODPO(0,3)
+ SIGDPO(4) = SBODPO(0,4)
+ SIGHAR = SBOHAR(0)
+ SIGDIR = SBOHAD(0)
+ ENDIF
+
+ B24=DCMPLX(B**2,0.D0)/4.D0
+
+ AMPEL = CZERO
+ AMPR = CZERO
+ AMPO = CZERO
+ AMPP = CZERO
+ AMPQ = CZERO
+ AMLMSD(1) = CZERO
+ AMLMSD(2) = CZERO
+ AMHMSD(1) = CZERO
+ AMHMSD(2) = CZERO
+ AMLMDD = CZERO
+ AMHMDD = CZERO
+
+C different models
+
+ IF(ISWMDL(1).LT.3) THEN
+C pomeron
+ AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
+C reggeon
+ AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
+C hard resolved processes
+ AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
+C hard direct processes
+ AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
+C triple-Pomeron: baryon high mass diffraction
+ AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
+ & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
+C triple-Pomeron: photon/meson high mass diffraction
+ AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
+ & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
+C loop-Pomeron
+ AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
+ ENDIF
+
+ IF(ISWMDL(1).EQ.0) THEN
+ AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
+ & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
+ & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
+ & )
+ AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+
+ ELSE IF(ISWMDL(1).EQ.1) THEN
+ AMPR = 0.5D0*SQRT(VDMQ2F(1))*
+ & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
+ AMPO = 0.5D0*SQRT(VDMQ2F(2))*
+ & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
+ AMPP = 0.5D0*SQRT(VDMQ2F(3))*
+ & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
+ AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
+ & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
+ AMPEL = SQRT(VDMQ2F(1))*AMPR
+ & + SQRT(VDMQ2F(2))*AMPO
+ & + SQRT(VDMQ2F(3))*AMPP
+ & + SQRT(VDMQ2F(4))*AMPQ
+ & + AUXD/2.D0
+
+C simple analytic two channel model (version A)
+ ELSE IF(ISWMDL(1).EQ.3) THEN
+ CALL PHO_CHAN2A(B)
+
+ ELSE
+ WRITE(LO,'(1X,A,I2)')
+ & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
+ STOP
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DSIGDT.FOR
+*COPY PHO_DSIGDT
+CDECK ID>, PHO_DSIGDT
+ SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
+C*********************************************************************
+C
+C calculation of unitarized amplitude
+C and differential cross section
+C
+C input: EE cm energy (GeV)
+C XTA(1,*) t values (GeV**2)
+C NFILL entries in t table
+C
+C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
+C XTA(3,*) DSIG/DT g p --> rho0 h/V
+C XTA(4,*) DSIG/DT g p --> omega0 h/V
+C XTA(5,*) DSIG/DT g p --> phi h/V
+C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+ DIMENSION XTA(6,NFILL)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ COMPLEX*16 XT,AMP,CZERO
+ DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
+ CHARACTER*12 FNA
+
+ CDABS(AMPEL) = ABS(AMPEL)
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+ CZERO=DCMPLX(0.D0,0.D0)
+
+ ETMP = ECM
+ ECM = EE
+
+ IF(NFILL.GT.100) THEN
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
+ STOP
+ ENDIF
+C
+ DO 100 K=1,NFILL
+ DO 150 L=1,5
+ XT(L,K)=CZERO
+ 150 CONTINUE
+ 100 CONTINUE
+C
+C impact parameter integration
+C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
+ BMAX=10.D0
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+ IAMP = 5
+ IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
+ I1 = 1
+ I2 = 0
+ ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
+ I1 = 0
+ I2 = 1
+ ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE
+ I1 = 0
+ I2 = 0
+ IAMP = 1
+ ENDIF
+ J1 = I1*2
+ K1 = I1*3
+ L1 = I1*4
+ J2 = I2*2
+ K2 = I2*3
+ L2 = I2*4
+C
+ DO 200 I=1,NGAUSO
+ WG=WGHT(I)*XPNT(I)
+C calculate amplitudes
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(1,-1,XPNT(I))
+ ELSE
+ CALL PHO_EIKON(1,1,XPNT(I))
+ ENDIF
+ AMP(1) = AMPEL
+ AMP(2) = AMPVM(I1,I2)
+ AMP(3) = AMPVM(J1,J2)
+ AMP(4) = AMPVM(K1,K2)
+ AMP(5) = AMPVM(L1,L2)
+C
+ DO 400 J=1,NFILL
+ XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
+ FAC = PHO_BESSJ0(XX)*WG
+ DO 500 K=1,IAMP
+ XT(1,J)=XT(1,J)+AMP(K)*FAC
+ 500 CONTINUE
+ 400 CONTINUE
+ 200 CONTINUE
+C
+C change units to mb/GeV**2
+ FAC = 4.D0*PI/GEV2MB
+ FNA = '(mb/GeV**2) '
+ IF(I1+I2.EQ.1) THEN
+ FAC = FAC*THOUS
+ FNA = '(mub/GeV**2)'
+ ELSE IF(I1+I2.EQ.2) THEN
+ FAC = FAC*THOUS*THOUS
+ FNA = '(nb/GeV**2) '
+ ENDIF
+ IF(IDEB(56).GE.5) THEN
+ WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
+ & FNA,'------------------------------------------'
+ ENDIF
+ DO 600 J=1,NFILL
+ DO 700 K=1,IAMP
+ XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
+ 700 CONTINUE
+ IF(IDEB(56).GE.5) THEN
+ WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
+ ENDIF
+ 600 CONTINUE
+
+ ECM = ETMP
+ END
+
+*$ CREATE PHO_XSECT.FOR
+*COPY PHO_XSECT
+CDECK ID>, PHO_XSECT
+ SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
+C*********************************************************************
+C
+C calculation of physical cross sections
+C
+C input: IP particle combination
+C IFHARD -1 reset Born graph cross section tables
+C 0 calculate hard cross sections or take them
+C from interpolation table (if available)
+C 1 assume that hard cross sections are already
+C calculated and stored in /POSBRN/
+C EE cms energy (GeV)
+C
+C output: /POSBRN/ input cross sections
+C /POZBRN/ scaled input cross values
+C /POCSEC/ physical cross sections and slopes
+C
+C slopes in GeV**-2, cross sections in mb
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ONEM=-1.D0,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+
+ CHARACTER*15 PHO_PNAME
+
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
+ CHARACTER*8 VMESA(0:4),VMESB(0:4)
+ DATA VMESA / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+ DATA VMESB / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+
+ CDABS(AMPEL) = ABS(AMPEL)
+
+ ETMP = ECM
+ IF(EE.LT.0.D0) GOTO 500
+ ECM = EE
+
+C impact parameter integration
+C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
+ BMAX=10.D0
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+ SIGTOT = 0.D0
+ SIGINE = 0.D0
+ SIGELA = 0.D0
+ SIGNDF = 0.D0
+ SIGLSD(1) = 0.D0
+ SIGLSD(2) = 0.D0
+ SIGLDD = 0.D0
+ SIGHSD(1) = 0.D0
+ SIGHSD(2) = 0.D0
+ SIGHDD = 0.D0
+ SIGCDF(0) = 0.D0
+ SIG1SO = 0.D0
+ SIG1HA = 0.D0
+ SLEL1 = 0.D0
+ SLEL2 = 0.D0
+ DO 50 I=1,4
+ SIGCDF(I) = 0.D0
+ DO 55 K=1,4
+ SIGVM(I,K) = 0.D0
+ SLVM1(I,K) = 0.D0
+ SLVM2(I,K) = 0.D0
+ 55 CONTINUE
+ 50 CONTINUE
+
+ DO 100 I=1,NGAUSO
+ B2 = XPNT(I)**2
+ WG = WGHT(I)*XPNT(I)
+ WGB = B2*WG
+
+C calculate impact parameter amplitude, results in /POINT4/
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(IP,IFHARD,XPNT(I))
+ ELSE
+ CALL PHO_EIKON(IP,1,XPNT(I))
+ ENDIF
+
+ SIGTOT = SIGTOT + DREAL(AMPEL)*WG
+ SIGELA = SIGELA + CDABS(AMPEL)**2*WG
+ SLEL1 = SLEL1 + AMPEL*WGB
+ SLEL2 = SLEL2 + AMPEL*WG
+
+ DO 110 J=1,4
+ DO 120 K=1,4
+ SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
+ SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
+ SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
+ 120 CONTINUE
+ SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
+ 110 CONTINUE
+
+ SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
+ SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
+ SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
+ SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
+ SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
+ SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
+ SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
+ SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
+
+ 100 CONTINUE
+
+ SIGDIR = DREAL(SIGHD)
+ FAC = 4.D0*PI2
+ SIGTOT = SIGTOT*FAC
+ SIGELA = SIGELA*FAC
+ FACSL = 0.5D0/GEV2MB
+ SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
+
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
+ DO 130 I=1,4
+ DO 140 J=1,4
+ SIGVM(I,J) = SIGVM(I,J)*FAC
+ SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
+ 140 CONTINUE
+ 130 CONTINUE
+ SIGVM(0,0) = 0.D0
+ DO 150 I=1,4
+ SIGVM(0,I) = 0.D0
+ SIGVM(I,0) = 0.D0
+ DO 160 J=1,4
+ SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
+ SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
+ 160 CONTINUE
+ SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
+ 150 CONTINUE
+ ENDIF
+
+C diffractive cross sections
+
+ SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
+ SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
+ SIGLDD = SIGLDD *FAC*PARMDL(42)
+ SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
+ SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
+ SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
+ & *FAC*PARMDL(42)
+
+C double pomeron scattering
+
+ SIGCDF(0) = 0.D0
+ DO 170 I=1,4
+ SIGCDF(I) = SIGCDF(I)*FAC
+ SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
+ 170 CONTINUE
+
+ SIG1SO = SIG1SO *FAC
+ SIG1HA = SIG1HA *FAC
+
+ SIGINE = SIGTOT - SIGELA
+
+C user-forced change of diffractive cross section
+
+ IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
+
+C use optional explicit parametrization for single-diffraction
+
+ SIGSD1 = SIGLSD(1)+SIGHSD(1)
+ SIGSD2 = SIGLSD(2)+SIGHSD(2)
+ SS = EE*EE
+ XI_MIN = 1.5D0/SS
+ XI_MAX = PARMDL(45)**2
+ CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
+ & SIG_SD1,SIG_SD2,SIG_DD)
+ SIG_SD1 = SIG_SD1*PARMDL(40)
+ SIG_SD2 = SIG_SD2*PARMDL(41)
+
+**sr
+C DEL_SD1 = SIG_SD1-SIGSD1
+ DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
+**
+
+ FAC = SIGLSD(1)/SIGSD1
+ SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
+ SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
+
+C DEL_SD2 = SIG_SD2-SIGSD2
+ DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
+
+ FAC = SIGLSD(2)/SIGSD2
+ SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
+ SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
+
+ IF(ISWMDL(30).GE.2) THEN
+
+C use explicit parametrization also for double diffraction diss.
+ SIGDD = SIGLDD+SIGHDD
+ SIG_DD = SIG_DD*PARMDL(42)
+ DEL_DD = SIG_DD-SIGDD
+ FAC = SIGLDD/SIGDD
+ SIGLDD = SIGLDD+FAC*DEL_DD
+ SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
+ SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
+
+ ELSE
+
+C rescale double diffraction cross sections
+ SIGLDD = SIGLDD *PARMDL(42)
+ SIGHDD = SIGHDD *PARMDL(42)
+ SIGCOR = DEL_SD1 + DEL_SD2
+ & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
+
+ ENDIF
+
+ ELSE
+
+C rescale unitarized cross sections for diffraction dissociation
+
+ SIGLSD(1) = SIGLSD(1)*PARMDL(40)
+ SIGHSD(1) = SIGHSD(1)*PARMDL(40)
+ SIGLSD(2) = SIGLSD(2)*PARMDL(41)
+ SIGHSD(2) = SIGHSD(2)*PARMDL(41)
+ SIGLDD = SIGLDD *PARMDL(42)
+ SIGHDD = SIGHDD *PARMDL(42)
+ SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
+ & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
+ & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
+
+ ENDIF
+
+C non-diffractive inelastic cross section
+
+ SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD
+
+C specify elastic scattering channel
+
+ 500 CONTINUE
+ IF(IFPAP(1).NE.22) THEN
+ VMESA(1) = PHO_PNAME(IFPAB(1),0)
+ ELSE
+ VMESA(1) = 'rho '
+ ENDIF
+ IF(IFPAP(2).NE.22) THEN
+ VMESB(1) = PHO_PNAME(IFPAB(2),0)
+ ELSE
+ VMESB(1) = 'rho '
+ ENDIF
+
+C write out physical cross sections
+
+ IF(IDEB(57).GE.5) THEN
+ WRITE(LO,'(/1X,A,I3,/1X,A)')
+ & 'PHO_XSECT: cross sections (mb) for combination',IP,
+ & '----------------------------------------------'
+ WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
+ WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
+ WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
+ WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
+ WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
+ & SIGLSD(1)+SIGHSD(1)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
+ & SIGLSD(2)+SIGHSD(2)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
+ DO 200 I=1,4
+ DO 210 J=1,4
+ IF(SIGVM(I,J).GT.DEPS) THEN
+ WRITE(LO,'(1X,3A)') 'q-elastic production of ',
+ & VMESA(I),VMESB(J)
+ WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
+ IF((I.NE.0).AND.(J.NE.0))
+ & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
+ ENDIF
+ 210 CONTINUE
+ 200 CONTINUE
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
+ WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
+ WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
+ WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
+ WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
+ WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
+ WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
+ & DREAL(DSIGH(15))
+ ENDIF
+ ENDIF
+
+ ECM = ETMP
+
+ END
+
+*$ CREATE PHO_IMPAMP.FOR
+*COPY PHO_IMPAMP
+CDECK ID>, PHO_IMPAMP
+ SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
+C*********************************************************************
+C
+C calculation of physical impact parameter amplitude
+C
+C input: EE cm energy (GeV)
+C BMIN lower bound in B
+C BMAX upper bound in B
+C NSTEP number of values (linear)
+C
+C output: values written to output unit
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ONEM=-1.D0,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ ECM=EE
+ BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
+C
+ WRITE(LO,'(3(/,1X,A))')
+ & 'impact parameter amplitudes:',
+ & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
+ & '-------------------------------------------------------------'
+C
+ BB = BMIN
+ DO 100 I=1,NSTEP
+C calculate impact parameter amplitudes
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(1,-1,BMIN)
+ ELSE
+ CALL PHO_EIKON(1,1,BB)
+ ENDIF
+ WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
+ & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
+ & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
+ BB = BB+BSTEP
+ 100 CONTINUE
+
+ END
+
+*$ CREATE PHO_PRBDIS.FOR
+*COPY PHO_PRBDIS
+CDECK ID>, PHO_PRBDIS
+ SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
+C*********************************************************************
+C
+C calculation of multi interactions probabilities
+C
+C input: IP particle combination to scatter
+C ECM CMS energy
+C IE index for weight storing
+C /PROBAB/
+C IMAX max. number of soft pomeron interactions
+C KMAX max. number of hard pomeron interactions
+C
+C output: /PROBAB/
+C PROB field of probabilities
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS=1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C Born graph cross sections after applying diffraction model
+ DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
+ & SBOLPO,SBODPO
+ COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
+ & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
+ & SBODPO(0:4,4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+
+C local variables
+ DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
+ PARAMETER (ICHMAX=40)
+ DIMENSION CHIFAC(4,4),AMPCOF(4)
+ DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
+ DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
+
+C combinatorical factors
+ DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
+ & 1.D0,-1.D0, 1.D0,-1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0 /
+
+ DATA FACLOG / .000000000000000D+00,
+ & .000000000000000D+00, .693147180559945D+00,
+ & .109861228866811D+01, .138629436111989D+01,
+ & .160943791243410D+01, .179175946922805D+01,
+ & .194591014905531D+01, .207944154167984D+01,
+ & .219722457733622D+01, .230258509299405D+01,
+ & .239789527279837D+01, .248490664978800D+01,
+ & .256494935746154D+01, .263905732961526D+01,
+ & .270805020110221D+01, .277258872223978D+01,
+ & .283321334405622D+01, .289037175789616D+01,
+ & .294443897916644D+01, .299573227355399D+01,
+ & .304452243772342D+01, .309104245335832D+01,
+ & .313549421592915D+01, .317805383034795D+01,
+ & .321887582486820D+01, .325809653802148D+01,
+ & .329583686600433D+01, .333220451017520D+01,
+ & .336729582998647D+01, .340119738166216D+01 /
+
+ DATA ELAST / 0.D0 /
+ DATA IPLAST / 0 /
+
+C test for redundant calculation: skip cs calculation
+ IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
+ ELAST = ECM
+ IPLAST = IP
+ CALL PHO_XSECT(IP,0,ELAST)
+ ISIMAX = IE
+ SIGECM(IP,IE) = ECM
+ SIGTAB(IP,1,IE) = SIGTOT
+ SIGTAB(IP,2,IE) = SIGELA
+ J = 2
+ DO 5 I=0,4
+ DO 6 K=0,4
+ J = J+1
+ SIGTAB(IP,J,IE) = SIGVM(I,K)
+ 6 CONTINUE
+ 5 CONTINUE
+ SIGTAB(IP,28,IE) = SIGINE
+ SIGTAB(IP,29,IE) = SIGDIR
+ SIGTAB(IP,30,IE) = SIGLSD(1)
+ SIGTAB(IP,31,IE) = SIGLSD(2)
+ SIGTAB(IP,32,IE) = SIGHSD(1)
+ SIGTAB(IP,33,IE) = SIGHSD(2)
+ SIGTAB(IP,34,IE) = SIGLDD
+ SIGTAB(IP,35,IE) = SIGHDD
+ SIGTAB(IP,36,IE) = SIGCDF(0)
+ SIGTAB(IP,37,IE) = SIG1SO
+ SIGTAB(IP,38,IE) = SIG1HA
+ SIGTAB(IP,39,IE) = SLOEL
+ J = 39
+ DO 7 I=1,4
+ DO 8 K=1,4
+ J = J+1
+ SIGTAB(IP,J,IE) = SLOVM(I,K)
+ 8 CONTINUE
+ 7 CONTINUE
+ SIGTAB(IP,56,IE) = SIGPOM
+ SIGTAB(IP,57,IE) = SIGREG
+ SIGTAB(IP,58,IE) = SIGHAR
+ SIGTAB(IP,59,IE) = SIGDIR
+ SIGTAB(IP,60,IE) = SIGTR1(1)
+ SIGTAB(IP,61,IE) = SIGTR1(2)
+ SIGTAB(IP,62,IE) = SIGTR2(1)
+ SIGTAB(IP,63,IE) = SIGTR2(2)
+ SIGTAB(IP,64,IE) = SIGLOO
+ SIGTAB(IP,65,IE) = SIGDPO(1)
+ SIGTAB(IP,66,IE) = SIGDPO(2)
+ SIGTAB(IP,67,IE) = SIGDPO(3)
+ SIGTAB(IP,68,IE) = SIGDPO(4)
+
+C consistency check
+ SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD
+
+ IF(SIGNDF.LE.0.D0) THEN
+ WRITE(LO,'(//1X,A,/)')
+ & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
+ WRITE(LO,'(4X,A,/1P,8E10.3)')
+ &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
+ & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
+ & SIGLSD(2),SIGLDD
+ STOP
+ ENDIF
+
+ IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
+ write(LO,*) '------------------------------------------------'
+ write(LO,*) 'IP,ECM:',IP,ECM
+ write(LO,*) 'SIGTOT:',SIGTOT
+ write(LO,*) 'SIGELA:',SIGELA
+ write(LO,*) 'SIGVM :',SIGVM(0,0)
+ write(LO,*) 'SIGCDF:',SIGCDF(0)
+ write(LO,*) 'SIGDIR:',SIGDIR
+ write(LO,*) 'SIGLSD:',SIGLSD
+ write(LO,*) 'SIGHSD:',SIGHSD
+ write(LO,*) 'SIGLDD:',SIGLDD
+ write(LO,*) 'SIGHDD:',SIGHDD
+ write(LO,*) 'SIGNDF:',SIGNDF
+
+ write(LO,*) 'SIGPOM:',SIGPOM
+ write(LO,*) 'SIGREG:',SIGREG
+ write(LO,*) 'SIGHAR:',SIGHAR
+ write(LO,*) 'SIGDIR:',SIGDIR
+ write(LO,*) 'SIGTR1:',SIGTR1
+ write(LO,*) 'SIGTR2:',SIGTR2
+ write(LO,*) 'SIGLOO:',SIGLOO
+ write(LO,*) 'SIGDPO:',SIGDPO
+ write(LO,*) 'SIG1SO:',SIG1SO
+ write(LO,*) 'SIG1HA:',SIG1HA
+ ENDIF
+
+ SIGTAB(IP,77,IE) = PTCUT(IP)
+ SIGTAB(IP,78,IE) = SIGNDF
+
+ AUXFAC = PI2/SIGNDF
+ IF(ISWMDL(1).EQ.3) THEN
+ DO 133 I=1,4
+ AMPCOF(I) = 0.D0
+ DO 135 K=1,4
+ AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
+ 135 CONTINUE
+ AMPCOF(I) = AMPCOF(I)*AUXFAC
+ 133 CONTINUE
+ ENDIF
+C
+* BMAX=5.D0*SQRT(DBLE(BPOM))
+ BMAX=10.D0
+ EPTAB(IP,IE) = ECM
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+C
+ ENDIF
+C
+ DO 160 K=0,KMAX
+ DO 170 I=0,IMAX
+ PROB(IP,IE,I,K) = 0.D0
+ 170 CONTINUE
+ 160 CONTINUE
+ DO 120 I=1,ICHMAX
+ PCHAIN(1,I) = 0.D0
+ PCHAIN(2,I) = 0.D0
+ 120 CONTINUE
+C
+C main cross section loop
+C**********************************************************
+ DO 5000 IB=1,NGAUSO
+ B24=XPNT(IB)**2/4.D0
+ FAC = XPNT(IB)*WGHT(IB)
+C
+ IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
+C
+C amplitude construction
+ DO 525 I=1,4
+ AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
+ & +ZXR(1,I)*EXP(-B24/BXR(1,I))
+ AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
+ AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
+ & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
+ & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
+ & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
+ & -ZXL(1,I)*EXP(-B24/BXL(1,I))
+ AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
+ & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
+ & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
+ & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
+ AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
+ AB(2,I) = AB(2,I)
+ AB(3,I) = 0.D0
+ AB(4,I) = 0.D0
+*
+ 525 CONTINUE
+C
+ DO 460 I=1,4
+ DO 500 K=1,4
+ ABSUM2(I,K) = 0.D0
+ DO 550 L=1,4
+ ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
+ 550 CONTINUE
+ ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
+ 500 CONTINUE
+ 460 CONTINUE
+ DO 600 I=1,4
+ CHI2(I) = 0.D0
+ DO 650 K=1,4
+ CHI2(I) = CHI2(I) + ABSUM2(K,I)
+ 650 CONTINUE
+ 600 CONTINUE
+C sums instead of products
+ DO 660 I=1,4
+ DO 670 KD=1,4
+ DTMP = ABS(ABSUM2(I,KD))
+ IF(DTMP.LT.1.D-30) THEN
+ ABSUM2(I,KD) = -50.D0
+ ELSE
+ ABSUM2(I,KD) = LOG(DTMP)
+ ENDIF
+ 670 CONTINUE
+ 660 CONTINUE
+
+ IF(MAX(IMAX,KMAX).GT.30) THEN
+ WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
+ & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
+ CALL PHO_ABORT
+ ENDIF
+
+ DO 700 KD=1,4
+ DO 750 I=1,4
+ ABSTMP(I) = ABSUM2(I,KD)
+ 750 CONTINUE
+C recursive sum
+ CHITMP(1) = -ABSUM2(1,KD)
+ DO 800 I=0,IMAX
+ CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
+ CHITMP(2) = -ABSTMP(2)
+ DO 810 K=0,KMAX
+ CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
+C calculation of elastic part
+ DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
+ IF(DTMP.LT.-30.D0) THEN
+ DTMP = 0.D0
+ ELSE
+ DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
+ ENDIF
+ PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
+ 810 CONTINUE
+ 800 CONTINUE
+ 700 CONTINUE
+ PROB(IP,IE,0,0) = 0.D0
+C
+C**********************************************************
+ ELSE
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
+ STOP
+ ENDIF
+ 5000 CONTINUE
+
+C debug output
+ IF(IDEB(55).GE.15) THEN
+ WRITE(LO,'(/,1X,A,I3,E11.4)')
+ & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
+ & IP,ECM
+ DO 905 I=0,MIN(IMAX,5)
+ DO 915 K=0,MIN(KMAX,5)
+ IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
+ & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
+ 915 CONTINUE
+ 905 CONTINUE
+ ENDIF
+C string probability (uncorrected)
+ IF(IDEB(55).GE.5) THEN
+ DO 955 I=0,IMAX
+ DO 965 K=0,KMAX
+ INDX = 2*I+2*K
+ IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
+ PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
+ ENDIF
+ 965 CONTINUE
+ 955 CONTINUE
+ WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
+ & 'list of selected probabilities (uncorr,ECM)',ECM
+ WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
+ DO 183 I=0,IIMAX
+ IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
+ & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
+ & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
+ 183 CONTINUE
+ ENDIF
+C substract high-mass single and double diffraction
+ PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
+ & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
+ PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
+C
+C probability check
+ CHKSUM = 0.D0
+ PRONEG = 0.D0
+ AVERI = 0.D0
+ AVERK = 0.D0
+ AVERL = 0.D0
+ AVERM = 0.D0
+ AVERN = 0.D0
+ SIGMI = 0.D0
+ SIGMK = 0.D0
+ SIGML = 0.D0
+ SIGMM = 0.D0
+ DO 1001 I=0,IMAX
+ PSOFT(I) = 0.D0
+ 1001 CONTINUE
+ DO 1002 K=0,KMAX
+ PHARD(K) = 0.D0
+ 1002 CONTINUE
+ DO 1000 K=0,KMAX
+ DO 1010 I=0,IMAX
+ TMP = PROB(IP,IE,I,K)
+ IF(TMP.LT.0.D0) THEN
+ IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
+ WRITE(LO,'(1X,A,4I4,E14.4)')
+ & 'PHO_PRBDIS: neg.probability:',
+ & IP,IE,I,K,PROB(IP,IE,I,K)
+ ENDIF
+ PRONEG = PRONEG+TMP
+ TMP = 0.D0
+ ENDIF
+ CHKSUM = CHKSUM+TMP
+ AVERI = AVERI+DBLE(I)*TMP
+ AVERK = AVERK+DBLE(K)*TMP
+ SIGMI = SIGMI+DBLE(I**2)*TMP
+ SIGMK = SIGMK+DBLE(K**2)*TMP
+ PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
+ PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
+ PROB(IP,IE,I,K) = CHKSUM
+ 1010 CONTINUE
+ 1000 CONTINUE
+C
+ IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
+ & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
+C cut probabilites output
+ IF(IDEB(55).GE.5) THEN
+ WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
+ DO 185 I=1,ICHMAX
+ IF(ABS(PCHAIN(1,I)).GT.1.D-10)
+ & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
+ 185 CONTINUE
+ ENDIF
+C rescaling necessary
+ IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
+ FAC = 1.D0/CHKSUM
+ IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
+ & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
+ DO 40 K=0,KMAX
+ DO 50 I=0,IMAX
+ PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
+ 50 CONTINUE
+ 40 CONTINUE
+ AVERI = AVERI*FAC
+ AVERK = AVERK*FAC
+ AVERL = AVERL*FAC
+ AVERM = AVERM*FAC
+ SIGMI = SIGMI*FAC**2
+ SIGMK = SIGMK*FAC**2
+ SIGML = SIGML*FAC**2
+ SIGMM = SIGMM*FAC**2
+ ENDIF
+C
+C probability to find Reggeon/Pomeron
+ PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
+ AVERJ = -PROB(IP,IE,0,0)*AVERI
+ AVERII = AVERI-AVERJ
+C
+ SIGTAB(IP,74,IE) = AVERII
+ SIGTAB(IP,75,IE) = AVERK
+ SIGTAB(IP,76,IE) = AVERJ
+C
+ SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
+ SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
+C
+ IF(IDEB(55).GE.1) THEN
+
+C average interaction probabilities
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_PRBDIS: expected interaction statistics',
+ & '-------------------------------------------'
+ WRITE(LO,'(1X,A,E12.4,2I3)')
+ & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
+ WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
+ & IMAX,KMAX
+ WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
+ & 'averaged number of cuts per event (eff. cs):',SIGNDF,
+ & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
+ & AVERII,AVERK,AVERJ,AVERL,AVERM,
+ & AVERI+AVERK+AVERL+AVERM
+ WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
+ & 'standard deviation ( sqrt(sigma) ):',
+ & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
+ & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
+ & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
+ WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
+ DO I=0,MIN(IMAX,KMAX)
+ WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
+ & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
+ ENDDO
+
+C cross check of probability distribution and inclusive cross section
+ PSsum_1 = 0.D0
+ PSsum_2 = 0.D0
+ PHsum_1 = 0.D0
+ PHsum_2 = 0.D0
+ do i=1,IMAX
+ PSsum_1 = PSsum_1+PSOFT(i)*FAC
+ PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
+ enddo
+ do k=1,KMAX
+ PHsum_1 = PHsum_1+PHARD(k)
+ PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
+ enddo
+ WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
+ & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SAMPRO.FOR
+*COPY PHO_SAMPRO
+CDECK ID>, PHO_SAMPRO
+ SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
+C***********************************************************************
+C
+C routine to sample kind of process
+C
+C input: IP particle combination
+C IFP1/2 PDG number of particle 1/2
+C ECM c.m. energy (GeV)
+C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
+C SPROB suppression factor for processes 1-7
+C due to rapidity gap survival probability
+C IPROC mode
+C -2 output of statistics
+C -1 initialization
+C 0 sampling of process
+C
+C output: IPROC kind of interaction process:
+C 1 non-diffractive resolved process
+C 2 elastic scattering
+C 3 quasi-elastic rho/omega/phi production
+C 4 central diffraction
+C 5 single diffraction according to IDIFF1
+C 6 single diffraction according to IDIFF2
+C 7 double diffraction
+C 8 single-resolved / direct processes
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER IP,IFP1,IFP2,IPROC
+ DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
+ DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
+ DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
+
+ INTEGER I,K,KMAX
+ DOUBLE PRECISION DT_RNDM
+ DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
+
+ IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
+ & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
+ & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
+
+ IF(IPROC.GE.0) THEN
+
+C interpolate cross sections
+ CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
+
+C cross check
+ IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
+ WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
+ & 'PHO_SAMPRO: inconsistent gap survival probability',
+ & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
+ & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
+ ENDIF
+
+C calculate cumulative probabilities
+ IF(ISWMDL(1).EQ.3) THEN
+ IF(ISWMDL(2).GE.1) THEN
+ SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
+ SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
+ SIGDDI = SIGLDD+SIGHDD
+ SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & - SIGSDI(1)-SIGSDI(2)-SIGDDI
+ XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
+ XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
+ XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
+ XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
+ XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
+ XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
+ XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
+ XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
+ ELSE
+ SIGHR = 0.D0
+ IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
+ SIGHD = 0.D0
+ IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
+ XPROB(1) = SIGHR/(SIGHR+SIGHD)
+ XPROB(2) = XPROB(1)
+ XPROB(3) = XPROB(1)
+ XPROB(4) = XPROB(1)
+ XPROB(5) = XPROB(1)
+ XPROB(6) = XPROB(1)
+ XPROB(7) = XPROB(1)
+ XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
+ ENDIF
+
+ IF(IDEB(11).GE.15) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_SAMPRO: partial cross sections for IP',IP
+ WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
+ DO 240 I=2,8
+ WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
+ 240 CONTINUE
+ ENDIF
+
+ ELSE
+ WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
+ & ISWMDL(1)
+ CALL PHO_ABORT
+ ENDIF
+
+ IF(XPROB(8).LT.1.D-20) THEN
+ IF(IDEB(11).GE.2)
+ & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
+ & 'activated processes have vanishing cross section sum',
+ & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
+ IPROC = 0
+ RETURN
+ ENDIF
+
+C sample process
+ XI = DT_RNDM(XI)*XPROB(8)
+ DO 100 I=1,8
+ IF(XI.LE.XPROB(I)) GOTO 110
+ 100 CONTINUE
+ 110 CONTINUE
+ IPROC = MIN(I,8)
+
+ CALLS(IP) = CALLS(IP)+1.D0
+ PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
+ ECMSUM(IP) = ECMSUM(IP)+ECM
+ IF(ISWMDL(2).GE.1) THEN
+ SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
+ ELSE
+ SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
+ ENDIF
+
+C debug output
+ IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
+ & 'PHO_SAMPRO: IP,CALL,PROC-ID',
+ & IP,INT(CALLS(IP)+0.1D0),IPROC
+
+C statistics initialization
+ ELSE IF(IPROC.EQ.-1) THEN
+ DO 260 K=1,4
+ DO 250 I=1,8
+ PRO(I,K) = 0.D0
+ 250 CONTINUE
+ CALLS(K) = 0.D0
+ SIGSUM(K) = 0.D0
+ ECMSUM(K) = 0.D0
+ 260 CONTINUE
+
+C write out statistics
+ ELSE IF(IPROC.EQ.-2) THEN
+ KMAX = 4
+ IF(ISWMDL(2).EQ.0) KMAX=1
+ DO 270 K=1,KMAX
+ IF(CALLS(K).GT.0.5D0) THEN
+ SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
+ ECMSUM(K) = ECMSUM(K)/CALLS(K)
+ IF(IDEB(11).GE.0) THEN
+ WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
+ & 'PHO_SAMPRO: internal process statistics ',
+ & '(IP,<Ecm>)',K,ECMSUM(K),
+ & '---------------------------------------'
+ WRITE(LO,'(8X,A)')
+ & ' process sampled cross section'
+ IF(ISWMDL(2).GE.1) THEN
+ WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
+ & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
+ & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
+ & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
+ & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
+ & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
+ & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
+ & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
+ & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
+ & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
+ ELSE
+ WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
+ & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
+ & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
+ & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
+ ENDIF
+ ENDIF
+ ENDIF
+ 270 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SAMPRB.FOR
+*COPY PHO_SAMPRB
+CDECK ID>, PHO_SAMPRB
+ SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
+C********************************************************************
+C
+C routine to sample number of cut graphs of different kind
+C
+C input: IP scattering particle combination
+C ECMI CMS energy
+C IP -1 initialization
+C -2 output of statistics
+C others sampling of cuts
+C
+C output: ISAM number of soft Pomerons cut
+C JSAM number of soft Reggeons cut
+C KSAM number of hard Pomerons cut
+C
+C PHO_PRBDIS has to be called before
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
+
+C sample number of interactions
+ IF(IP.GE.0) THEN
+ ITER = 0
+ ECMX = ECMI
+ ECMC = ECMI
+ KLIM = 1
+ IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
+ IF(IPAMDL(16).EQ.0) ECMC = SECM
+ KLIM = 0
+ ENDIF
+
+C sample up to kinematic limits only
+ IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
+ IF(IMAX1.LT.1) THEN
+ IF(IPAMDL(2).EQ.1) THEN
+C reggeon allowed
+ ISAM = 0
+ JSAM = 1
+ KSAM = 0
+ AVERB(3,IP) = AVERB(3,IP)+1.D0
+ ELSE
+C only pomeron even at very low energies
+ ISAM = 1
+ JSAM = 0
+ KSAM = 0
+ AVERB(1,IP) = AVERB(1,IP)+1.D0
+ ENDIF
+ AVERB(0,IP) = AVERB(0,IP)+1.D0
+ GOTO 150
+ ENDIF
+C find interpolation factors
+ IF(ECMX.LE.EPTAB(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
+ DO 50 I=2,IEEMAX
+ IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = IEEMAX
+ I2 = IEEMAX
+ ENDIF
+ FAC2 = 0.D0
+ IF(I1.NE.I2)
+ & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
+ FAC1=1.D0-FAC2
+C reggeon probability
+ PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
+C calculate soft suppression factor
+ IF(IP.EQ.1) FSUPP = PARMDL(35)**2
+ & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
+C
+ 10 CONTINUE
+ ITER = ITER+1
+ XI = DT_RNDM(FAC2)
+ DO 260 KSAM=0,KMAX
+ DO 270 ISAM=0,IMAX
+ PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
+ & +PROB(IP,I2,ISAM,KSAM)*FAC2
+ IF(PRO.GT.XI) GOTO 100
+ 270 CONTINUE
+ 260 CONTINUE
+ ISAM = MIN(IMAX,ISAM)
+ KSAM = MIN(KMAX,KSAM)
+
+ 100 CONTINUE
+
+ IF(ITER.GT.100) THEN
+
+ ISAM = 0
+ JSAM = 1
+ KSAM = 0
+ IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
+ & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
+
+ ELSE
+
+C reggeon contribution
+ JSAM = 0
+ IF(IPAMDL(2).EQ.1) THEN
+ DO 90 I=1,ISAM
+ IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
+ 90 CONTINUE
+ ISAM = ISAM-JSAM
+ ENDIF
+C statistics of bare cuts
+ IF(ITER.EQ.1) THEN
+ AVERB(0,IP) = AVERB(0,IP)+1.D0
+ AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
+ AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
+ AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
+ ENDIF
+C limitation given by field dimensions
+ IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
+
+ IF(IP.EQ.1) THEN
+
+C reweight according to virtualities and PDF treatment
+ IF(IPAMDL(115).GE.1) THEN
+ IF(KSAM.EQ.0) THEN
+ IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
+ ENDIF
+ ENDIF
+
+C reduce number of cuts according to photon virtualities
+ IF(IPAMDL(114).GE.1) THEN
+ 110 CONTINUE
+ I = ISAM+JSAM
+ WGX = FSUPP**I
+ IF(DT_RNDM(WGX).GT.WGX) THEN
+ IF(ISAM+JSAM+KSAM.GT.1) THEN
+ IF(JSAM.GT.0) THEN
+ JSAM = JSAM-1
+ GOTO 110
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ GOTO 110
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+C phase space limitation
+ 120 CONTINUE
+ XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
+ & +DBLE(2*KSAM)*PTCUT(IP)
+ PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
+ IF(DT_RNDM(XM).GT.PACC) THEN
+ IF(ISAM+JSAM+KSAM.GT.1) THEN
+ IF(JSAM.GT.0) THEN
+ JSAM = JSAM-1
+ GOTO 120
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ GOTO 120
+ ELSE IF(KSAM.GT.KLIM) THEN
+ KSAM = KSAM-1
+ GOTO 120
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ISAM = ISAM+JSAM/2
+ JSAM = MOD(JSAM,2)
+C collect statistics
+ 150 CONTINUE
+ ECMS1(IP) = ECMS1(IP)+ECMX
+ ECMS2(IP) = ECMS2(IP)+ECMC
+
+ AVERC(0,IP) = AVERC(0,IP)+1.D0
+ AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
+ AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
+ AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
+C
+ IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
+ & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
+C
+C initialize statistics
+ ELSE IF(IP.EQ.-1) THEN
+ DO 60 I=1,4
+ ECMS1(I) = 0.D0
+ ECMS2(I) = 0.D0
+ DO 65 K=0,3
+ AVERB(K,I) = 0.D0
+ AVERC(K,I) = 0.D0
+ 65 CONTINUE
+
+ 60 CONTINUE
+ RETURN
+C
+C write out statistics
+ ELSE IF(IP.EQ.-2) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
+ & '----------------------------------'
+ DO 70 I=1,4
+ IF(AVERB(0,I).LT.2.D0) GOTO 75
+ WRITE(LO,'(1X,A,I3,1P,2E13.3)')
+ & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
+ & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
+ WRITE(LO,'(5X,A)')
+ & 'average number of s-pom,h-pom,reg cuts (bare)'
+ WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
+ & (AVERB(K,I)/AVERB(0,I),K=1,3)
+ WRITE(LO,'(5X,A)')
+ & 'average (with energy/virtuality corrections)'
+ WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
+ & (AVERC(K,I)/AVERC(0,I),K=1,3)
+
+ 75 CONTINUE
+ 70 CONTINUE
+ RETURN
+ ENDIF
+ END
+
+*$ CREATE PHO_TRIREG.FOR
+*COPY PHO_TRIREG
+CDECK ID>, PHO_TRIREG
+ SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
+ & SIGTR,BTR)
+C**********************************************************************
+C
+C calculation of triple-Pomeron total cross section
+C according to Gribov's Regge theory
+C
+C input: S squared cms energy
+C GA coupling constant to diffractive line
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C GPPP triple-Pomeron coupling
+C BPPP slope related to B0PPP (GeV**-2)
+C VIR2A virtuality of particle a (GeV**2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGTR total triple-Pomeron cross section
+C BTR effective triple-Pomeron slope
+C (differs from diffractive slope!)
+C
+C uses E_i (Exponential-Integral function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
+ SIGU = 2.5
+C integration cut-off Sigma_L (min. squared mass of diff. blob)
+ SIGL = 5.+VIR2A
+C debug output
+ IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(S.LT.5.D0) THEN
+ SIGTR = 0.D0
+ BTR = BPPP+BB
+ RETURN
+ ENDIF
+C change units of ALPHAP to mb
+ ALSCA = ALPHAP*GEV2MB
+C
+C cross section
+ PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
+ & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
+ PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
+ PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
+C
+ SIGTR=PART1*(PART2-PART3)
+C
+C slope
+ PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
+ & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
+ PART2 = LOG(PART1)
+ PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
+ BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
+ BTR = BTR-PART1
+C
+ IF(SIGTR.LT.EPS) SIGTR = 0.D0
+ IF(BTR.LT.BB) BTR = BB
+C
+ IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
+ END
+
+*$ CREATE PHO_LOOREG.FOR
+*COPY PHO_LOOREG
+CDECK ID>, PHO_LOOREG
+ SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
+ & VIR2A,VIR2B,SIGLO,BLO)
+C**********************************************************************
+C
+C calculation of loop-Pomeron total cross section
+C according to Gribov's Regge theory
+C
+C input: S squared cms energy
+C GA coupling constant to diffractive line
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C GPPP triple-Pomeron coupling
+C BPPP slope related to B0PPP (GeV**-2)
+C VIR2A virtuality of particle a (GeV**2)
+C VIR2B virtuality of particle b (GeV**2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGLO total loop-Pomeron cross section
+C BLO effective loop-Pomeron slope
+C (differs from double diffractive slope!)
+C
+C uses E_i (Exponential-Integral function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
+ SIGU = 2.5
+C integration cut-off Sigma_L (min. squared mass of diff. blob)
+ SIGL = 5.+VIR2A+VIR2B
+C debug output
+ IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(S.LT.5.D0) THEN
+ SIGLO = 0.D0
+ BLO = 2.D0*BPPP
+ RETURN
+ ENDIF
+
+C
+C change units of ALPHAP to mb
+ ALSCA = ALPHAP*GEV2MB
+C
+C cross section
+ PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
+ & EXP(-DELTA*BPPP/ALPHAP)
+ PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
+ PARTB=BPPP/ALPHAP+LOG(SIGU)
+ SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
+ & -PHO_EXPINT(PARTB*DELTA))
+ & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
+ & )
+C
+C slope
+ PART1 = LOG(ABS(PARTA/PARTB))
+ & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
+ PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
+ BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
+ BLO = BLO-PART1
+C
+ IF(SIGLO.LT.EPS) SIGLO = 0.D0
+ IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
+C
+ IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
+ END
+
+*$ CREATE PHO_TRXPOM.FOR
+*COPY PHO_TRXPOM
+CDECK ID>, PHO_TRXPOM
+ SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
+ & GPPP,BPPP,SIGDP,BDP)
+C**********************************************************************
+C
+C calculation of total cross section of two tripe-Pomeron
+C graphs in X configuration according to Gribov's Reggeon field
+C theory
+C
+C input: S squared cms energy
+C GA coupling constant to elastic line 1
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line 2
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C BPPP triple-Pomeron coupling
+C BTR slope related to B0PPP (GeV**-2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGDP total cross section for double-Pomeron
+C scattering
+C BDP effective double-Pomeron slope
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION XWGH1(96),XPOS1(96)
+
+C lower integration cut-off Sigma_L
+ SIGL = PARMDL(71)**2
+C upper integration cut-off Sigma_U
+ C = 1.D0-1.D0/PARMDL(70)**2
+ C = MAX(PARMDL(72),C)
+ SIGU = (1.D0-C)**2*S
+C integration precision
+ NGAUS1=16
+C
+C debug output
+ IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(SIGU.LE.SIGL) THEN
+ SIGDP = 0.D0
+ BDP = AA+BB
+ RETURN
+ ENDIF
+C
+C cross section
+C
+ XIL = LOG(SIGL)
+ XIU = LOG(SIGU)
+ XI = LOG(S)
+ FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
+ ALPHA2 = 2.D0*ALPHAP
+ ALOC = LOG(1.D0/(1.D0-C))
+ CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
+ XSUM = 0.D0
+ DO 100 I1=1,NGAUS1
+ AMXSQ = EXP(XPOS1(I1))
+ ALOSMX = LOG(S/AMXSQ)
+ ALCSMX = LOG((1.D0-C)*S/AMXSQ)
+ W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
+ W = MAX(0.D0,W)
+ WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
+C supercritical part
+ WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
+ XSUM = XSUM + W*XWGH1(I1)/WN*WSC
+ 100 CONTINUE
+ SIGDP = XSUM*FAC
+C
+C slope
+ BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
+C
+ IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
+ END
+
+*$ CREATE PHO_CHAN2A.FOR
+*COPY PHO_CHAN2A
+CDECK ID>, PHO_CHAN2A
+ SUBROUTINE PHO_CHAN2A(BB)
+C***********************************************************************
+C
+C simple two channel model to realize low mass diffraction
+C (version A, iteration of triple- and loop-Pomeron)
+C
+C input: BB impact parameter (mb**1/2)
+C
+C output: /POINT4/
+C AMPEL elastic amplitude
+C AMPVM(4,4) q-elastic VM production
+C AMLMSD(2) low mass single diffraction amplitude
+C AMHMSD(2) high mass single diffraction amplitude
+C AMLMDD low mass double diffraction amplitude
+C AMHMDD high mass double diffraction amplitude
+C AMPDP(4) central diffraction amplitude
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-5,
+ & EIGHT = 8.D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+C unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+
+C local variables
+ DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
+ & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
+ & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
+ DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
+
+C combinatorical factors
+ DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
+ & 1.D0,-1.D0, 1.D0,-1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0 /
+ DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & -1.D0, 1.D0,-1.D0, 1.D0,
+ & -1.D0,-1.D0, 1.D0, 1.D0 /
+ DATA IELTAB / 1, 2, 3, 4,
+ & 2, 1, 4, 3,
+ & 3, 4, 1, 2,
+ & 4, 3, 2, 1 /
+
+ IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_CHAN2A: impact parameter B',BB
+
+ B24 = BB**2/4.D0
+ DO 25 I=1,4
+ AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
+ & +ZXR(1,I)*EXP(-B24/BXR(1,I))
+ AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
+ AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
+ AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
+ AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
+ & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
+ & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
+ AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
+ AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
+ AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
+ AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
+ 25 CONTINUE
+
+ DO 50 I=1,4
+ ABSUM(I) = 0.D0
+ DO 75 II=9,1,-1
+ ABSUM(I) = ABSUM(I) + AB(II,I)
+ 75 CONTINUE
+ 50 CONTINUE
+ IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
+ & 'PHO_CHAN2A: ABSUM',ABSUM
+
+ DO 100 I=1,4
+ CHI(I) = 0.D0
+ CHDS(I) = 0.D0
+ CHDH(I) = 0.D0
+ CHDA(I) = 0.D0
+ CHDB(I) = 0.D0
+ CHDD(I) = 0.D0
+ CHDPE(I) = 0.D0
+ CHDPA(I) = 0.D0
+ CHDPB(I) = 0.D0
+ CHDPD(I) = 0.D0
+ AMPELA(I,0) = 0.D0
+ AMPELA(I,9) = 0.D0
+ DO 200 K=1,4
+ AMPELA(I,K) = 0.D0
+ AMPELA(I,K+4) = 0.D0
+ AMPVM(I,K) = 0.D0
+ CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
+ CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
+ CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
+ CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
+ CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
+ CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
+ CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
+ CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
+ CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
+ CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
+ 200 CONTINUE
+ IF(CHI(I).LT.-DEPS) THEN
+ IF(IDEB(86).GE.0) THEN
+ WRITE(LO,'(1X,A,I3,2E12.3)')
+ & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
+ WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
+ ENDIF
+ ENDIF
+ IF(ABS(CHI(I)).GT.200.D0) THEN
+ EX1CHI(I) = 0.D0
+ EX2CHI(I) = 0.D0
+ ELSE
+ TMP = EXP(-CHI(I))
+ EX1CHI(I) = TMP
+ EX2CHI(I) = TMP*TMP
+ ENDIF
+ 100 CONTINUE
+ IF(IDEB(86).GE.20) THEN
+ WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
+ ENDIF
+
+ AMPELA(1,0) = 4.D0
+ DO 300 K=1,4
+ DO 400 J=1,4
+ CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
+ AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
+ AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
+ AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
+ AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
+ AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
+ AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
+ AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
+ AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
+ AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
+ AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
+ 400 CONTINUE
+ 300 CONTINUE
+
+ IF(IDEB(86).GE.25) THEN
+ DO 305 I=1,9
+ WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
+ & (AMPELA(K,1),K=1,4)
+ 305 CONTINUE
+ ENDIF
+
+C VDM factors --> amplitudes
+C low mass excitations
+ DO 500 I=1,4
+ AMPCHA(I) = 0.D0
+ DO 600 K=1,4
+ AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
+ 600 CONTINUE
+ 500 CONTINUE
+ AMPVME = AMPCHA(1)/EIGHT
+ AMLMSD(1) = AMPCHA(2)/EIGHT
+ AMLMSD(2) = AMPCHA(3)/EIGHT
+ AMLMDD = AMPCHA(4)/EIGHT
+C elastic part, high mass diffraction
+ AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
+ AMPSOF = 0.D0
+ AMPHAR = 0.D0
+ AMHMSD(1) = 0.D0
+ AMHMSD(2) = 0.D0
+ AMHMDD = 0.D0
+ AMPDP(1) = 0.D0
+ AMPDP(2) = 0.D0
+ AMPDP(3) = 0.D0
+ AMPDP(4) = 0.D0
+ DO 450 I=1,4
+ AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
+ AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
+ AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
+ AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
+ AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
+ AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
+ AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
+ AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
+ AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
+ AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
+ 450 CONTINUE
+ AMPSOF = AMPSOF/16.D0
+ AMPHAR = AMPHAR/16.D0
+ AMHMSD(1) = AMHMSD(1)/16.D0
+ AMHMSD(2) = AMHMSD(2)/16.D0
+ AMHMDD = AMHMDD/16.D0
+ AMPDP(1) = AMPDP(1)/16.D0
+ AMPDP(2) = AMPDP(2)/16.D0
+ AMPDP(3) = AMPDP(3)/16.D0
+ AMPDP(4) = AMPDP(4)/16.D0
+ IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
+ IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
+ IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
+ IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
+ IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
+ IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
+ IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
+
+C vector-meson production, weight factors
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
+ IF(IFPAP(1).EQ.22) THEN
+ IF(IFPAP(2).EQ.22) THEN
+ DO 10 I=1,4
+ DO 15 J=1,4
+ AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
+ 15 CONTINUE
+ 10 CONTINUE
+ ELSE
+ AMPVM(1,1) = PARMDL(10)*AMPVME
+ AMPVM(2,1) = PARMDL(11)*AMPVME
+ AMPVM(3,1) = PARMDL(12)*AMPVME
+ AMPVM(4,1) = PARMDL(13)*AMPVME
+ ENDIF
+ ELSE IF(IFPAP(2).EQ.22) THEN
+ AMPVM(1,1) = PARMDL(10)*AMPVME
+ AMPVM(1,2) = PARMDL(11)*AMPVME
+ AMPVM(1,3) = PARMDL(12)*AMPVME
+ AMPVM(1,4) = PARMDL(13)*AMPVME
+ ENDIF
+ ENDIF
+C debug output
+ IF(IDEB(86).GE.5) THEN
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_CHAN2A: impact parameter amplitudes'
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
+ WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
+ ENDIF
+
+ END
+
+*$ CREATE PHO_EVENT.FOR
+*COPY PHO_EVENT
+CDECK ID>, PHO_EVENT
+ SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
+C********************************************************************
+C
+C main subroutine to manage simulation processes
+C
+C input: NEV -1 initialization
+C 1 generation of events
+C 2 generation of events without rejection
+C due to energy dependent cross section
+C 3 generation of events without rejection
+C using initialization energy
+C -2 output of event generation statistics
+C P1(4) momentum of particle 1 (internal TARGET)
+C P2(4) momentum of particle 2 (internal PROJECTILE)
+C FAC used for initialization:
+C contains cross section the events corresponds to
+C during generation: current cross section
+C
+C output: IREJ 0: event accepted
+C 1: event rejected
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY = 1.D-10 )
+
+ DIMENSION P1(4),P2(4)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
+
+ IREJ = 0
+
+C initializations
+ IF(NEV.EQ.-1) THEN
+ WRITE(LO,'(/3(/1X,A))')
+ & '=======================================================',
+ & ' ------- initialization of event generation --------',
+ & '======================================================='
+ CALL PHO_SETMDL(0,0,-2)
+C amplitude parameters
+ CALL PHO_FITPAR(1)
+
+ CALL PHO_REJSTA(-1)
+C initialize MC package
+ CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
+ CALL PHO_MCINI
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 0.D0,-1)
+ CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
+
+C cross section
+ FAC = SIGGEN(4)
+ DO 20 I=1,10
+ IPRSAM(I) = 0
+ IPRACC(I) = 0
+ IENACC(I) = 0
+ 20 CONTINUE
+ ISPS = 0
+ ISPA = 0
+ ISRS = 0
+ ISRA = 0
+ IHPS = 0
+ IHPA = 0
+ ISTS = 0
+ ISTA = 0
+ ISLS = 0
+ ISLA = 0
+ IDIS = 0
+ IDIA = 0
+ IDPS = 0
+ IDPA = 0
+ IDNS(1) = 0
+ IDNS(2) = 0
+ IDNS(3) = 0
+ IDNS(4) = 0
+ IDNA(1) = 0
+ IDNA(2) = 0
+ IDNA(3) = 0
+ IDNA(4) = 0
+ KACCEP = 0
+ KEVENT = 0
+ KEVGEN = 0
+ ECMSUM = 0.D0
+ ELSE IF(NEV.GT.0) THEN
+C
+C -------------- begin event generation ---------------
+C
+ IPAMDL(13) = 0
+ IF(NEV.EQ.3) IPAMDL(13) = 1
+ KEVENT = KEVENT+1
+C enable debugging
+ CALL PHO_TRACE(0,0,0)
+ IF(IDEB(68).GE.2) THEN
+ IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
+ & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
+ ENDIF
+ CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
+C cross section calculation
+ FAC = SIGGEN(3)
+ IF(NEV.EQ.1) THEN
+ IF(IVWGHT(1).EQ.1) THEN
+ WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
+ ELSE
+ WG = SIGGEN(3)/SIGGEN(4)
+ ENDIF
+ IF(DT_RNDM(FAC).GT.WG) THEN
+ IREJ = 1
+ IF(IDEB(68).GE.6) THEN
+ WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
+ & 'PHO_EVENT: rejection due to cross section',
+ & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
+ & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ KEVGEN = KEVGEN+1
+ SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
+ HSWGHT(0) = MAX(1.D0,WG)
+
+ ITRY1 = 0
+ 50 CONTINUE
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+
+C sample process
+ IPROCE = 0
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 1.D0,IPROCE)
+ IF(IPROCE.EQ.0) THEN
+ IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
+ & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
+ IREJ = 50
+ RETURN
+ ENDIF
+C sampling statistics
+ IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
+
+ ITRY2 = 0
+ 60 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+C sample number of cut graphs according to IPROCE and
+C generate parton configurations+strings
+ CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
+C collect statistics
+ ISPS = ISPS+KSPOM
+ IHPS = IHPS+KHPOM
+ ISRS = ISRS+KSREG
+ ISTS = ISTS+KSTRG+KHTRG
+ ISLS = ISLS+KSLOO+KHLOO
+ IDIS = IDIS+MIN(KHDIR,1)
+ IDPS = IDPS+KHDPO+KSDPO
+ IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
+ & IDNS(KHDIR) = IDNS(KHDIR)+1
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(68).GE.4) THEN
+ WRITE(LO,'(/1X,A,2I5)')
+ & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
+ RETURN
+ ENDIF
+ IFAIL(1) = IFAIL(1)+1
+ IF(ITRY1.GT.5) RETURN
+ IF(IREJ.GE.5) THEN
+ IF(ISWMDL(2).EQ.0) RETURN
+ GOTO 50
+ ENDIF
+ IF(ITRY2.LT.5) GOTO 60
+ GOTO 50
+ ENDIF
+C fragmentation of strings
+
+C FSR and string fragmentation is done separately by DPMJET routines
+C CALL PHO_STRFRA(IREJ)
+
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IFAIL(23) = IFAIL(23)+1
+ IF(IDEB(68).GE.4) THEN
+ WRITE(LO,'(/1X,A,2I5)')
+ & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ GOTO 50
+ ENDIF
+C check of conservation of quantum numbers
+ IF(IDEB(68).GE.-5) THEN
+ CALL PHO_CHECK(-1,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ ENDIF
+C event now completely processed and accepted
+C acceptance statistics
+ IPRACC(IPROCE) = IPRACC(IPROCE)+1
+ ISPA = ISPA+KSPOM
+ IHPA = IHPA+KHPOM
+ ISRA = ISRA+KSREG
+ ISTA = ISTA+(KSTRG+KHTRG)
+ ISLA = ISLA+(KSLOO+KHLOO)
+ IDIA = IDIA+MIN(KHDIR,1)
+ IDPA = IDPA+KHDPO+KSDPO
+ IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
+ & IDNA(KHDIR) = IDNA(KHDIR)+1
+ DO 55 I=1,IPOIX2
+ IENACC(IPORES(I)) = IENACC(IPORES(I))+1
+ 55 CONTINUE
+ KACCEP = KACCEP+1
+
+C debug output (partial / full event listing)
+ if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
+ & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
+ IF(IDEB(67).GE.10) THEN
+ IF(IDEB(67).LE.15) THEN
+ CALL PHO_PREVNT(-1)
+ ELSE IF(IDEB(67).LE.20) THEN
+ CALL PHO_PREVNT(0)
+ ELSE IF(IDEB(67).LE.25) THEN
+ CALL PHO_PREVNT(1)
+ ELSE
+ CALL PHO_PREVNT(2)
+ ENDIF
+ ENDIF
+C
+C effective weight
+ DO 65 I=1,10
+ IF(IPOWGC(I).GT.0) THEN
+ HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
+ ENDIF
+ 65 CONTINUE
+ IF(IVWGHT(1).EQ.1) THEN
+ WG = HSWGHT(0)
+ IF(WG.GT.1.01D0) THEN
+ IF(EVWGHT(1).LT.1.01D0) THEN
+ WRITE(LO,'(1X,A,2I12,1PE12.3)')
+ & 'PHO_EVENT: cross section weight > 1',
+ & KEVENT,KACCEP,WG
+ WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
+ & SIGGEN(3),SIGGEN(4),EVWGHT(1)
+ ENDIF
+ EVWGHT(1) = HSWGHT(0)
+ HSWGHT(0) = 1.D0
+ ELSE
+ EVWGHT(1) = 1.D0
+ ENDIF
+ ENDIF
+
+C effective cross section
+ SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
+ ECMSUM = ECMSUM+ECM
+ SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
+ ELSE IF(NEV.EQ.-2) THEN
+
+C ---------------- end of event generation ----------------------
+
+ WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
+ & '====================================================',
+ & ' --------- summary of event generation ----------',
+ & '====================================================',
+ & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
+ & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
+
+C write out statistics
+ IF(KACCEP.GT.0) THEN
+
+ FAC1 = SIGGEN(4)/DBLE(KEVENT)
+ FAC2 = FAC/DBLE(KACCEP)
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_EVENT: generated and accepted events',
+ & '----------------------------------------'
+ WRITE(LO,'(3X,A)')
+ & 'process, sampled, accepted, cross section (internal/external)'
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
+ & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
+ & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
+ & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
+ & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
+ & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
+ & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
+ & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
+ & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
+ & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
+ & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
+ & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
+ & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
+ & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
+ & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
+ & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
+ & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
+ WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
+ & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
+ IF(ISWMDL(14).GT.0) THEN
+ WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
+ & ISWMDL(14)
+ WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
+ WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
+ WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
+ WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
+ WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
+ ENDIF
+ WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
+ & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
+
+ CALL PHO_REJSTA(-2)
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 0.D0,-2)
+ CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
+C statistics of hard scattering processes
+ WRITE(LO,'(2(/1X,A))')
+ & 'PHO_EVENT: statistics of hard scattering processes',
+ & '--------------------------------------------------'
+ DO 43 K=1,4
+ IF(MH_tried(0,K).GT.0) THEN
+ WRITE(LO,'(/5X,A,I3)')
+ & 'process (accepted,x-section internal/external) for IP:',K
+ DO 47 M=0,Max_pro_2
+ WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
+ & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
+ & DBLE(MH_acc_2(M,K))*FAC2
+ 47 CONTINUE
+ ENDIF
+ 43 CONTINUE
+
+ ELSE
+ WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
+ ENDIF
+ WRITE(LO,'(/3(/1X,A)/)')
+ & '======================================================',
+ & ' ------- end of event generation summary --------',
+ & '======================================================'
+ ELSE
+ WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PARTON.FOR
+*COPY PHO_PARTON
+CDECK ID>, PHO_PARTON
+ SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
+C********************************************************************
+C
+C calculation of complete parton configuration
+C
+C input: IPROC process ID 1 nondiffractive
+C 2 elastic
+C 3 quasi-ela. rho,omega,phi prod.
+C 4 double Pomeron
+C 5 single diff 1
+C 6 single diff 2
+C 7 double diff diss.
+C 8 single-resolved / direct photon
+C JM1,2 index of mother particles in /POEVT1/
+C
+C
+C output: complete parton configuration in /POEVT1/
+C IREJ 1 failure
+C 0 success
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4)
+
+ PARAMETER ( TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+C clear event statistics
+ KSPOM = 0
+ KHPOM = 0
+ KSREG = 0
+ KHDIR = 0
+ KSTRG = 0
+ KHTRG = 0
+ KSLOO = 0
+ KHLOO = 0
+ KHARD = 0
+ KSOFT = 0
+ KSDPO = 0
+ KHDPO = 0
+
+C-------------------------------------------------------------------
+C nondiffractive resolved processes
+
+ IF(IPROC.EQ.1) THEN
+C sample number of interactions
+ 555 CONTINUE
+ IINT = 0
+ IP = 1
+C generate only hard events
+ IF(ISWMDL(2).EQ.0) THEN
+ MHPOM = 1
+ MSPOM = 0
+ MSREG = 0
+ MHDIR = 0
+ HSWGHT(1) = 1.D0
+ ELSE
+C minimum bias events
+ IPOWGC(1) = 0
+ 10 CONTINUE
+ CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
+ IPOWGC(1) = IPOWGC(1)+1
+ MINT = 0
+ MHDIR = 0
+ MSTRG = 0
+ MSLOO = 0
+C
+C resolved soft processes: pomeron and reggeon
+ MSPOM = IINT
+ MSREG = JINT
+C resolved hard process: hard pomeron
+ MHPOM = KINT
+C resolved absorptive corrections
+ MPTRI = 0
+ MPLOO = 0
+C restrictions given by user
+ IF(MSPOM.LT.ISWCUT(1)) GOTO 10
+ IF(MSREG.LT.ISWCUT(2)) GOTO 10
+ IF(MHPOM.LT.ISWCUT(3)) GOTO 10
+ HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
+C ----------------------------
+ IF(ISWMDL(15).EQ.0) THEN
+ MHPOM = 0
+ IF(MSREG.GT.0) THEN
+ MSPOM = 0
+ MSREG = 1
+ ELSE
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ ELSE IF(ISWMDL(15).EQ.1) THEN
+ IF(MHPOM.GT.0) THEN
+ MHPOM = 1
+ MSPOM = 0
+ MSREG = 0
+ ELSE IF(MSPOM.GT.0) THEN
+ MSPOM = 1
+ MSREG = 0
+ ELSE
+ MSREG = 1
+ ENDIF
+ ELSE IF(ISWMDL(15).EQ.2) THEN
+ MHPOM = MIN(1,MHPOM)
+ ELSE IF(ISWMDL(15).EQ.3) THEN
+ MSPOM = MIN(1,MSPOM)
+ ENDIF
+ ENDIF
+C ----------------------------
+
+C statistics
+ ISPS = ISPS+MSPOM
+ IHPS = IHPS+MHPOM
+ ISRS = ISRS+MSREG
+ ISTS = ISTS+MSTRG
+ ISLS = ISLS+MSLOO
+
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
+ & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
+ & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
+
+ ITRY2 = 0
+ 50 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+ KHDIR = MHDIR
+ KSTRG = MPTRI
+ KSLOO = MPLOO
+
+ CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ IF(MHPOM.GT.0) THEN
+ IDNODF = 3
+ ELSE IF(MSPOM.GT.0) THEN
+ IDNODF = 2
+ ELSE
+ IDNODF = 1
+ ENDIF
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.20) GOTO 50
+ IF(IDEB(3).GE.1) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C statistics
+ ISPA = ISPA+KSPOM
+ IHPA = IHPA+KHPOM
+ ISRA = ISRA+KSREG
+ ISTA = ISTA+KSTRG
+ ISLA = ISLA+KSLOO
+
+C-------------------------------------------------------------------
+C elastic scattering / quasi-elastic rho/omega/phi production
+
+ ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
+ & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
+
+C DPMJET call with special projectile / target: transform into CMS
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(1,JM1,JM2)
+
+ CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
+
+ IF(IREJ.NE.0) THEN
+C DPMJET call with special projectile / target: clean up
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(-2,JM1,JM2)
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C DPMJET call with special projectile / target: transform back
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(2,JM1,JM2)
+
+C prepare possible decays
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ RETURN
+ ENDIF
+
+C---------------------------------------------------------------------
+C double Pomeron scattering
+
+ ELSE IF(IPROC.EQ.4) THEN
+ MSOFT = 0
+ MHARD = 0
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
+ & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
+ IDPS = IDPS+1
+ ITRY2 = 0
+ 60 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+C
+ CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 60
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 60
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IDPA = IDPA+1
+
+C-----------------------------------------------------------------------
+C single / double diffraction dissociation
+
+ ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
+ MSOFT = 0
+ MHARD = 0
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
+ & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
+ IF(IPROC.EQ.5) ID1S = ID1S+1
+ IF(IPROC.EQ.6) ID2S = ID2S+1
+ IF(IPROC.EQ.7) ID3S = ID3S+1
+ ITRY2 = 0
+ 70 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ IPAR1 = 1
+ IPAR2 = 1
+ IF(IPROC.EQ.5) IPAR2 = 0
+ IF(IPROC.EQ.6) IPAR1 = 0
+C calculate rapidity gap survival probability
+ SPROB = 1.D0
+ IF(ECM.GT.10.D0) THEN
+ IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
+ IF(SIGTR1(1).LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
+ ENDIF
+ ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
+ IF(SIGTR2(1).LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
+ ENDIF
+ ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
+ IF(SIGLOO.LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHDD/SIGLOO
+ ENDIF
+ ENDIF
+ ENDIF
+
+**sr
+* temporary patch, r.e. 8.6.99
+ SPROB = 1.D0
+**
+
+C DPMJET call with special projectile / target: transform into CMS
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(1,JM1,JM2)
+
+ CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
+
+ IF(IREJ.NE.0) THEN
+C DPMJET call with special projectile / target: clean up
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(-2,JM1,JM2)
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C DPMJET call with special projectile / target: transform back
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(2,JM1,JM2)
+
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 70
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 70
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IF(IPROC.EQ.5) ID1A = ID1A+1
+ IF(IPROC.EQ.6) ID2A = ID2A+1
+ IF(IPROC.EQ.7) ID3A = ID3A+1
+
+C-----------------------------------------------------------------------
+C single / double direct processes
+
+ ELSE IF(IPROC.EQ.8) THEN
+ MSREG = 0
+ MSPOM = 0
+ MHPOM = 0
+ MHDIR = 1
+ IF(IDEB(3).GE.5) THEN
+ WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
+ ENDIF
+ IDIS = IDIS+MHDIR
+ ITRY2 = 0
+ 80 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+ KHDIR = 4
+
+ CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ IDNODF = 4
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 80
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 80
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IF(IPROC.EQ.5) ID1A = ID1A+1
+ IF(IPROC.EQ.6) ID2A = ID2A+1
+ IF(IPROC.EQ.7) ID3A = ID3A+1
+ IDIA = IDIA+MHDIR
+
+C-----------------------------------------------------------------------
+C initialize control statistics
+
+ ELSE IF(IPROC.EQ.-1) THEN
+ CALL PHO_SAMPRB(ECM,-1,0,0,0)
+ CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
+ CALL PHO_SEAFLA(-1,0,0,DUM)
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
+ & CALL PHO_QELAST(-1,1,2,0)
+ ISPS = 0
+ ISPA = 0
+ ISRS = 0
+ ISRA = 0
+ IHPS = 0
+ IHPA = 0
+ ISTS = 0
+ ISTA = 0
+ ISLS = 0
+ ISLA = 0
+ ID1S = 0
+ ID1A = 0
+ ID2S = 0
+ ID2A = 0
+ ID3S = 0
+ ID3A = 0
+ IDPS = 0
+ IDPA = 0
+ IDIS = 0
+ IDIA = 0
+ CALL PHO_STRING(-1,IREJ)
+ CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
+ RETURN
+
+C-----------------------------------------------------------------------
+C produce statistics summary
+
+ ELSE IF(IPROC.EQ.-2) THEN
+ IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
+ IF(IDEB(3).GE.0) THEN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_PARTON: internal statistics on parton configurations',
+ & '--------------------------------------------------------'
+ WRITE(LO,'(5X,A)') 'process sampled accepted'
+ WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
+ WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
+ WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
+ WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
+ WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
+ WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
+ WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
+ WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
+ WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
+ WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
+ ENDIF
+ CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
+ & CALL PHO_QELAST(-2,1,2,0)
+ CALL PHO_STRING(-2,IREJ)
+ CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
+ CALL PHO_SEAFLA(-2,0,0,DUM)
+ RETURN
+ ELSE
+ WRITE(LO,'(1X,A,I2)')
+ & 'PARTON:ERROR: unknown process ID ',IPROC
+ STOP
+ ENDIF
+
+ END
+
+*$ CREATE PHO_MCINI.FOR
+*COPY PHO_MCINI
+CDECK ID>, PHO_MCINI
+ SUBROUTINE PHO_MCINI
+C********************************************************************
+C
+C initialization of MC event generation
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PIMASS = 0.13D0,
+ & TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ CHARACTER*15 PHO_PNAME
+ DIMENSION ECMF(4)
+
+ DATA XMPOM / 0.766D0 /
+
+C initialize fragmentation
+ CALL PHO_FRAINI(ISWMDL(6))
+
+C reset interpolation tables
+ DO 50 I=1,4
+ DO 60 J=1,10
+ DO 70 K=1,70
+ SIGTAB(I,K,J) = 0.D0
+ 70 CONTINUE
+ SIGECM(I,J) = 0.D0
+ 60 CONTINUE
+ 50 CONTINUE
+
+C max. number of allowed colors (large N expansion)
+ IC1 = 0
+ IC2 = 10000
+ CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
+
+C lower energy limit of initialization
+ ETABLO = PARMDL(19)
+ IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
+
+ WRITE(LO,'(/,1X,A,2F12.1)')
+ & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
+ WRITE(LO,'(5X,A,A,F7.3,E15.4)')
+ & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
+ & PMASS(1),PVIRT(1)
+ WRITE(LO,'(5X,A,A,F7.3,E15.4)')
+ & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
+ & PMASS(2),PVIRT(2)
+
+C cuts on probabilities of multiple interactions
+ IMAX = MIN(IPAMDL(32),IIMAX)
+ KMAX = MIN(IPAMDL(33),KKMAX)
+ AH = 2.D0*PTCUT(1)/ECM
+ IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
+ KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
+
+C hard interpolation table
+ ECMF(1) = ECM
+ ECMF(2) = 0.9D0*ECMF(1)
+ ECMF(3) = ECMF(2)
+ ECMF(4) = ECMF(2)
+ do k=1,4
+ IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
+ IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
+ IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
+ IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
+ enddo
+
+C initialization of hard scattering for all channels and cutoffs
+ IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
+ I0 = 4
+ IF(ISWMDL(2).EQ.0) I0 = 1
+ DO 110 I=I0,1,-1
+ CALL PHO_HARMCI(I,ECMF(I))
+ 110 CONTINUE
+
+C dimension of interpolation table of cut probabilities
+ IEEMAX = MIN(IPAMDL(31),IEETA1)
+ IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
+ IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
+ IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
+ ISIMAX = IEEMAX
+
+C calculate probability distribution
+ I0 = 4
+ IFT1 = IFPAP(1)
+ IFT2 = IFPAP(2)
+ XMT1 = PMASS(1)
+ XMT2 = PMASS(2)
+ XVT1 = PVIRT(1)
+ XVT2 = PVIRT(2)
+ IF(ISWMDL(2).EQ.0) I0 = 1
+ DO 150 IP=I0,1,-1
+ ECMPRO = ECMF(IP)*1.001D0
+ IF(IP.EQ.4) THEN
+ IFPAP(1) = 990
+ IFPAP(2) = 990
+ PMASS(1) = XMPOM
+ PMASS(2) = XMPOM
+ PVIRT(1) = 0.D0
+ PVIRT(2) = 0.D0
+ ELSE IF(IP.EQ.3) THEN
+ IFPAP(1) = IFT2
+ IFPAP(2) = 990
+ PMASS(1) = XMT2
+ PMASS(2) = XMPOM
+ PVIRT(1) = XVT2
+ PVIRT(2) = 0.D0
+ ELSE IF(IP.EQ.2) THEN
+ IFPAP(1) = IFT1
+ IFPAP(2) = 990
+ PMASS(1) = XMT1
+ PMASS(2) = XMPOM
+ PVIRT(1) = XVT1
+ PVIRT(2) = 0.D0
+ ELSE
+ IFPAP(1) = IFT1
+ IFPAP(2) = IFT2
+ PMASS(1) = XMT1
+ PMASS(2) = XMT2
+ PVIRT(1) = XVT1
+ PVIRT(2) = XVT2
+ ENDIF
+ IF(IEEMAX.GT.1) THEN
+ IF(IP.EQ.1) THEN
+ ELMIN = LOG(ETABLO)
+ ELSE
+ ELMIN = LOG(2.5D0)
+ ENDIF
+ EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
+ DO 100 I=1,IEEMAX
+ ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
+ CALL PHO_PRBDIS(IP,ECMPRO,I)
+ 100 CONTINUE
+ ELSE
+ CALL PHO_PRBDIS(IP,ECMPRO,1)
+ ENDIF
+
+C debug output of cross section tables
+ IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
+ IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of total cross sections (mb) for particle combination',IP,
+ &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
+ &'-------------------------------------------------------------'
+ DO 200 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
+ & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
+ & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
+ & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
+ & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
+ 200 CONTINUE
+ 201 CONTINUE
+ IF(IDEB(62).GE.2) THEN
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of partial x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
+ &'--------------------------------------------------------------'
+ DO 205 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
+ & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
+ & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
+ 205 CONTINUE
+ ENDIF
+ IF(IDEB(62).GE.2) THEN
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of born graph x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
+ &'-------------------------------------------------------------'
+ DO 210 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
+ & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
+ & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
+ & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
+ & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
+ & +SIGTAB(IP,68,I)
+ 210 CONTINUE
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of unitarized x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
+ &'-------------------------------------------------------------'
+ DO 215 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
+ & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
+ & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
+ 215 CONTINUE
+ ENDIF
+ IF(IDEB(62).GE.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
+ &'Table of expected average number of cuts in non-diff events:',
+ &' for max. number of cuts soft/hard:',IMAX,KMAX,
+ &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
+ &'---------------------------------------------'
+ DO 220 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
+ & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
+ & SIGTAB(IP,76,I)
+ 220 CONTINUE
+ IF(IP.EQ.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
+ & 'Table of rapidity gap survival probability (high-mass diff.):',
+ & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
+ & '---------------------------------------------------'
+ DO 230 I=1,IEEMAX
+ IF(SIGECM(IP,I).GT.10.D0) THEN
+ SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
+ & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
+ SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
+ & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
+ SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
+ & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
+ & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
+ SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
+ & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
+ WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
+ & SPRSD1,SPRSD2,SPRDD,SPRCDF
+ ENDIF
+ 230 CONTINUE
+ ENDIF
+ ENDIF
+ ENDIF
+ 150 CONTINUE
+
+C simulate only hard scatterings
+ IF(ISWMDL(2).EQ.0) THEN
+ WRITE(LO,'(2(/1X,A))')
+ & 'WARNING: generation of hard scatterings only!',
+ & '============================================='
+ DO 151 I=2,7
+ IPRON(I,1) = 0
+ 151 CONTINUE
+ DO 152 K=2,4
+ DO 153 I=1,15
+ IPRON(I,K) = 0
+ 153 CONTINUE
+ 152 CONTINUE
+ SIGGEN(4) = 0.D0
+ DO 160 I=1,IEEMAX
+ SIGMAX = 0.D0
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
+ IF(SIGMAX.GT.SIGGEN(4)) THEN
+ ISIGM = I
+ SIGGEN(4) = SIGMAX
+ ENDIF
+ 160 CONTINUE
+ ELSE
+ WRITE(LO,'(2(/1X,A))')
+ & 'activated processes, cross section',
+ & '----------------------------------'
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' elastic scattering',(IPRON(2,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' double pomeron processes',(IPRON(4,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' double diffract. processes',(IPRON(7,K),K=1,4)
+ WRITE(LO,'(5X,A,I3,2X,3I3)')
+ & ' direct photon processes',(IPRON(8,K),K=1,4)
+
+C calculate effective cross section
+ SIGGEN(4) = 0.D0
+ DO 165 I=1,IEEMAX
+ CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
+ & PVIRT(1),PVIRT(2))
+ SIGMAX = 0.D0
+ if(iswmdl(2).ge.1) then
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
+ & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD-SIGDIR
+ IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
+ IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
+ IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
+ IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
+ IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
+ IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
+ else
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
+ endif
+ IF(SIGMAX.GT.SIGGEN(4)) THEN
+ ISIGM = I
+ SIGGEN(4) = SIGMAX
+ ENDIF
+ 165 CONTINUE
+ ENDIF
+
+C debug output
+ IF(SIGGEN(4).LT.1.D-20) THEN
+ WRITE(LO,'(//1X,A)')
+ & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
+ STOP
+ ENDIF
+ WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
+ & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
+ WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
+
+ END
+
+*$ CREATE PHO_REJSTA.FOR
+*COPY PHO_REJSTA
+CDECK ID>, PHO_REJSTA
+ SUBROUTINE PHO_REJSTA(IMODE)
+C********************************************************************
+C
+C MC rejection counting
+C
+C input IMODE -1 initialization
+C -2 output of statistics
+C
+C********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ INTEGER IMODE
+
+ INTEGER I
+
+C initialization
+ IF(IMODE.EQ.-1) THEN
+ DO 100 I=1,NMXJ
+ IFAIL(I) = 0
+ 100 CONTINUE
+C
+ REJTIT(1) = 'PARTON ALL'
+ REJTIT(2) = 'STDPAR ALL'
+ REJTIT(3) = 'STDPAR DPO'
+ REJTIT(4) = 'POMSCA ALL'
+ REJTIT(5) = 'POMSCA INT'
+ REJTIT(6) = 'POMSCA KIN'
+ REJTIT(7) = 'DIFDIS ALL'
+ REJTIT(8) = 'POSPOM ALL'
+ REJTIT(9) = 'HRES.DIF.1'
+ REJTIT(10) = 'HDIR.DIF.1'
+ REJTIT(11) = 'HRES.DIF.2'
+ REJTIT(12) = 'HDIR.DIF.2'
+ REJTIT(13) = 'DIFDIS INT'
+ REJTIT(14) = 'HADRON SP2'
+ REJTIT(15) = 'HADRON SP3'
+ REJTIT(16) = 'HARDIR ALL'
+ REJTIT(17) = 'HARDIR INT'
+ REJTIT(18) = 'HARDIR KIN'
+ REJTIT(19) = 'MCHECK BAR'
+ REJTIT(20) = 'MCHECK MES'
+ REJTIT(21) = 'DIF.DISS.1'
+ REJTIT(22) = 'DIF.DISS.2'
+ REJTIT(23) = 'STRFRA ALL'
+ REJTIT(24) = 'MSHELL CHA'
+ REJTIT(25) = 'PARTPT SOF'
+ REJTIT(26) = 'PARTPT HAR'
+ REJTIT(27) = 'INTRINS KT'
+ REJTIT(28) = 'HACHEK DIR'
+ REJTIT(29) = 'HACHEK RES'
+ REJTIT(30) = 'STRING ALL'
+ REJTIT(31) = 'POMSCA INT'
+ REJTIT(32) = 'DIFF SLOPE'
+ REJTIT(33) = 'GLU2QU ALL'
+ REJTIT(34) = 'MASCOR ALL'
+ REJTIT(35) = 'PARCOR ALL'
+ REJTIT(36) = 'MSHELL PAR'
+ REJTIT(37) = 'MSHELL ALL'
+ REJTIT(38) = 'POMCOR ALL'
+ REJTIT(39) = 'DB-POM KIN'
+ REJTIT(40) = 'DB-POM ALL'
+ REJTIT(41) = 'SOFTXX ALL'
+ REJTIT(42) = 'SOFTXX PSP'
+
+C write output
+ ELSE IF(IMODE.EQ.-2) THEN
+ WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
+ & '--------------------------------'
+ DO 300 I=1,NMXJ
+ IF(IFAIL(I).GT.0)
+ & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
+ 300 CONTINUE
+ ELSE
+ WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_POSPOM.FOR
+*COPY PHO_POSPOM
+CDECK ID>, PHO_POSPOM
+ SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
+C***********************************************************************
+C
+C registration of one cut pomeron (soft/semihard)
+C
+C input: IP particle combination the pomeron belongs to
+C IND1,2 position of X values in /POSOFT/
+C 1 corresponds to a valence-pomeron
+C IGEN production process of mother particles
+C IPOM pomeron number
+C KCUT total number of cut pomerons and reggeons
+C
+C output: ISWAP exchange of x values
+C IND1,2 increased by the number of partons belonging
+C to the generated pomeron cut
+C IREJ success/failure
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
+
+ IREJ = 0
+ ISWAP = 0
+ JM1 = NPOSP(1)
+ JM2 = NPOSP(2)
+ INDX1 = IND1
+ INDX2 = IND2
+ EA1 = XS1(IND1)*ECMP/2.D0
+ EA2 = XS1(IND1+1)*ECMP/2.D0
+ EB1 = XS2(IND2)*ECMP/2.D0
+ EB2 = XS2(IND2+1)*ECMP/2.D0
+ CMASS1 = MIN(EA1,EA2)
+ CMASS2 = MIN(EB1,EB2)
+
+C debug output
+ IF(IDEB(9).GE.20) THEN
+ WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
+ & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
+ WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
+ & CMASS1,CMASS2
+ ENDIF
+
+C flavours
+ IF(IND1.EQ.1) THEN
+ CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
+ ELSE
+ CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
+ ENDIF
+ IF(IND2.EQ.1) THEN
+ CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
+ ELSE
+ CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
+ ENDIF
+ DO 75 I=1,4
+ P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
+ P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
+ 75 CONTINUE
+
+C pomeron resolved?
+ IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
+C find energy for cross section calculation
+ IF(IPAMDL(16).EQ.2) THEN
+ ESUB = ECMP
+ ELSE IF(IPAMDL(16).EQ.3) THEN
+ IF(IPROCE.EQ.1) THEN
+ ESUB = ECM
+ ELSE
+ ESUB = ECMP
+ ENDIF
+ ELSE
+ ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
+ ENDIF
+C load cross sections from interpolation table
+ IF(ESUB.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 2
+ ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = ISIMAX-1
+ I2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1=1.D0-FAC2
+C calculate weights
+* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
+* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
+* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
+* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
+* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
+* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
+
+ WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
+ & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
+ WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
+ WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
+ WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
+ & +SIGTAB(IP,64,I2))
+ & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
+ & +SIGTAB(IP,64,I1))
+ WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
+ & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
+ & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
+ & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
+
+C one-pomeron cut
+ WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
+C central diff. cut
+ WGX(2) = WGXCDF
+C diff. diss. of particle 1
+ WGX(3) = WGXHSD(1)
+C diff. diss. of particle 2
+ WGX(4) = WGXHSD(2)
+C double diff. dissociation
+ WGX(5) = WGXHDD
+C two-pomeron cut
+ WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
+
+* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
+* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
+* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
+* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
+* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
+* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
+* ENDIF
+
+ SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
+
+C selection loop
+ 205 CONTINUE
+ XI = DT_RNDM(SUM)*SUM
+ I = 0
+ SUM = 0.D0
+ 210 CONTINUE
+ I = I+1
+ SUM = SUM+WGX(I)
+ IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
+C phase space correction
+ IF(I.NE.1) THEN
+ ISAM = 4
+ IF(I.EQ.6) ISAM = 8
+ PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
+* IF(DT_RNDM(SUM).GT.PACC) I=1
+ IF(DT_RNDM(SUM).GT.PACC) GOTO 205
+ ENDIF
+
+C do not generate diffraction for events with only one cut pomeron
+ IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
+
+C do not generate recursive calls for remants with
+C diquark-anti-diquark flavour contents
+ if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
+ if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
+
+C debug output
+ IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
+ & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
+
+ IF(I.GT.1) THEN
+C second scattering needed
+ CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
+ CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
+ IDPD1 = IPHO_ID2PDG(IDHA1)
+ IDPD2 = IPHO_ID2PDG(IDHA2)
+
+ if(INDX1.eq.1) then
+ if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
+ & IGEN_had = IGEN
+ else
+ IGEN_had = -IGEN
+ endif
+ CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
+ & IPOM,IGEN_had,0,0,IPOS1,1)
+
+ if(INDX2.eq.1) then
+ if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
+ & IGEN_had = IGEN
+ else
+ IGEN_had = -IGEN
+ endif
+ CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
+ & IPOM,IGEN_had,0,0,IPOS1,1)
+
+ IND1 = IND1+2
+ IND2 = IND2+2
+C update index
+ IPOIX2 = IPOIX2+1
+
+ IF(IPOIX2.GT.MAXIPX) THEN
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
+ & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IPORES(IPOIX2) = I+2
+ IPOPOS(1,IPOIX2) = IPOS1-1
+ IPOPOS(2,IPOIX2) = IPOS1
+ RETURN
+ ENDIF
+ ENDIF
+
+ 100 CONTINUE
+ IF(ISWMDL(12).EQ.0) THEN
+C sample colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
+
+C purely gluonic pomeron or sea strings formed by gluons
+
+ IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
+ & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
+ IFLA1 = 21
+ IFLA2 = 21
+ ENDIF
+ IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
+ & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
+ IFLB1 = 21
+ IFLB2 = 21
+ ENDIF
+
+C color connection
+ IF(IFLA1.NE.21) THEN
+ IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
+ & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
+ & CALL PHO_SWAPI(ICA1,ICD1)
+ ENDIF
+ IF(IFLB1.NE.21) THEN
+ IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
+ & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
+ & CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ISWAP = 0
+ IF(ICA1*ICB1.GT.0) THEN
+ IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
+ IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ELSE IF(IND1.NE.1) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE IF(IND2.NE.1) THEN
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
+ IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ELSE IF(IFLA1.EQ.-IFLA2) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE IF(IFLB1.EQ.-IFLB2) THEN
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ELSE
+ ISWAP = 1
+ IF(IDEB(9).GE.5) THEN
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
+ WRITE(LO,'(5X,A,4I7)')
+ & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
+ WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
+ ENDIF
+ ENDIF
+ ENDIF
+
+C registration
+
+C purely gluonic pomeron or sea strings formed by gluons
+ IF(IFLA1.EQ.21) THEN
+ CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
+ & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
+ IND1 = IND1+2
+
+C strings formed by quarks
+ ELSE
+C valence quark labels
+ IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
+ & .and.(IDHEP(JM1).NE.990)) THEN
+ ICA2 = 1
+ ICD2 = 1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
+ & ICA2,IPOS1,1)
+ IND1 = IND1+1
+ CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
+ & ICD2,IPOS,1)
+ IND1 = IND1+1
+
+ ENDIF
+
+C purely gluonic pomeron or sea strings formed by gluons
+ IF(IFLB1.EQ.21) THEN
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
+ & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
+ IND2 = IND2+2
+
+C strings formed by quarks
+ ELSE
+C valence quark labels
+ IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
+ & .and.(IDHEP(JM2).NE.990)) THEN
+ ICB2 = 1
+ ICC2 = 1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
+ & ICB2,IPOS,1)
+ IND2 = IND2+1
+ CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
+ & ICC2,IPOS2,1)
+ IND2 = IND2+1
+
+ ENDIF
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25)+1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+* CALL PHO_BFKL(P1,P2,IPART,IREJ)
+* IF(IREJ.NE.0) RETURN
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HADSP2.FOR
+*COPY PHO_HADSP2
+CDECK ID>, PHO_HADSP2
+ SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
+C***********************************************************************
+C
+C split hadron momentum XMAX into two partons using
+C lower cut-off: AS
+C
+C input: IFLB compressed particle code of particle to split
+C XS1 sum of x values already selected
+C XMAX maximal x possible
+C
+C output: XS1 new sum of x values (without first one)
+C XSOFT1 field of selected x values
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+ DIMENSION XSOFT1(50)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+C model exponents
+ DATA PVMES1 /-0.5D0/
+ DATA PVMES2 /-0.5D0/
+ DATA PVBAR1 / 1.5D0/
+ DATA PVBAR2 /-0.5D0/
+C
+ IREJ = 0
+ ITMAX = 100
+C
+C mesonic particle
+ IF(ipho_bar3(IFLB,0).EQ.0) THEN
+ XPOT1 = PVMES1+1.D0
+ XPOT2 = PVMES2+1.D0
+C baryonic particle
+ ELSE
+ XPOT1 = PVBAR1+1.D0
+ XPOT2 = PVBAR2+1.D0
+ ENDIF
+ ITER = 0
+ XREST= 1.D0-XS1
+C selection loop
+ 100 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.ITMAX) THEN
+ IF(IDEB(39).GE.3) THEN
+ WRITE(LO,'(1X,A,I8)')
+ & 'PHO_HADSP2: REJECTION (ITER)',ITER
+ WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
+ ENDIF
+ IFAIL(14) = IFAIL(14)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
+ IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
+ XSS1 = XS1 + ZZ
+ IF((1.D0-XSS1).LT.AS) GOTO 100
+C
+ XS1 = XSS1
+ XSOFT1(1) = 1.D0-XSS1
+ XSOFT1(2) = ZZ
+C debug output
+ IF(IDEB(39).GE.10) THEN
+ WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
+ WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
+ & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
+ ENDIF
+ END
+
+*$ CREATE PHO_HADSP3.FOR
+*COPY PHO_HADSP3
+CDECK ID>, PHO_HADSP3
+ SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
+C***********************************************************************
+C
+C split hadron momentum XMAX into diquark & quark pair
+C using lower cut-off: AS
+C
+C input: IFLB compressed particle code of particle to split
+C XS1 sum of x values already selected
+C XMAX maximal x possible
+C
+C output: XS1 new sum of x values
+C XSOFT1 field of selected x values
+C
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER ( DEPS = 1.D-8 )
+
+ DIMENSION XSOFT1(50),XSOFT2(50)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+ DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
+
+C model exponents
+ DATA PVMES1 /-0.5D0/
+ DATA PVMES2 /-0.5D0/
+ DATA PSMES /-0.99D0/
+ DATA PVBAR1 / 1.5D0/
+ DATA PVBAR2 /-0.5D0/
+ DATA PSBAR /-0.99D0/
+C
+ IREJ = 0
+C
+C determine exponents
+C particle 1
+C
+ XMMIN = 0.3D0/ECMP
+ XBMIN = 1.6D0/ECMP
+C mesonic particle
+ IF(ipho_bar3(IFLB,0).EQ.0) THEN
+ XPOT1(1) = PVMES1
+ XMIN(1,1) = XMMIN
+ XPOT1(2) = PVMES2
+ XMIN(1,2) = XMMIN
+ XPOT1(3) = PSMES
+ XMIN(1,3) = XMMIN
+C baryonic particle
+ ELSE
+ XPOT1(1) = PVBAR1
+ XMIN(1,1) = XBMIN
+ XPOT1(2) = PVBAR2
+ XMIN(1,2) = XMMIN
+ XPOT1(3) = PSBAR
+ XMIN(1,3) = XMMIN
+ ENDIF
+C particle 2
+C mesonic particle
+ XPOT2(1) = PVMES1
+ XMIN(2,1) = XMMIN
+ XPOT2(2) = PVMES2
+ XMIN(2,2) = XMMIN
+ XPOT2(3) = PSMES
+ XMIN(2,3) = XMMIN
+C
+ XDUM1 = 0.01D0
+ XDUM2 = 0.99D0
+ CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
+ & XSOFT1,XSOFT2,IREJ)
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
+ & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
+ IFAIL(15) = IFAIL(15)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+C debug output
+ IF(IDEB(74).GE.10) THEN
+ WRITE(LO,'(1X,A,I6,2E12.4)')
+ & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
+ DO 100 I=1,3
+ WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
+ 100 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SOFTXX.FOR
+*COPY PHO_SOFTXX
+CDECK ID>, PHO_SOFTXX
+ SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
+ & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
+C***********************************************************************
+C
+C select soft x values
+C
+C input: JM1,JM2 mother particle index in POEVT1
+C (0 flavour not known before)
+C MSPAR1,2 number of x values to select
+C IVAL1,2 number valence quarks involved in hard
+C scattering (0,1,2)
+C MSM1,2 minimum number of soft x to get sampled
+C XSUM1,2 sum of all x values samples up this call
+C XMAX1,2 max. x value
+C
+C output XSUM1,2 new sum of x-values sampled
+C XS1,2 field containing sampled x values
+C
+C x values of valence partons are first given
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ DIMENSION XS1(*),XS2(*)
+
+ INTEGER MAXPOT
+ PARAMETER ( MAXPOT = 50 )
+ DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
+
+ IREJ = 0
+
+ MSMAX = MAX(MSPAR1,MSPAR2)
+ MSMIN = MAX(MSM1,MSM2)
+
+ IF(MSMAX.GT.MAXPOT) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
+ & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
+ IREJ = 1
+ RETURN
+ ENDIF
+
+C determine exponents
+ IBAR1 = ipho_bar3(JM1,2)
+ IBAR2 = ipho_bar3(JM2,2)
+ ISWAP = 0
+ IF((IBAR1*IBAR2).LT.0) ISWAP = 1
+C meson-baryon scattering (asymmetric sea)
+ IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
+ PSBAR = PARMDL(53)
+ PSMES = PARMDL(57)
+ ELSE
+ PSBAR = PARMDL(52)
+ PSMES = PARMDL(56)
+ ENDIF
+
+C lower limits for x sampling
+ XMMINA = 2.D0*PARMDL(157)/ECMP
+ XBMINA = 2.D0*PARMDL(158)/ECMP
+ XSMINA = 2.D0*PARMDL(159)/ECMP
+ XMIN1 = MAX(XSOMIN,AS/XMAX2)
+ XMIN2 = MAX(XSOMIN,AS/XMAX1)
+ XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
+ XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
+ XMIN1 = MAX(AS/XMAX2,XMIN1)
+ XMIN2 = MAX(AS/XMAX1,XMIN2)
+
+C particle 1
+ XMMIN1 = MAX(XMIN1,XMMINA)
+ XBMIN1 = MAX(XMIN1,XBMINA)
+ XSMIN1 = MAX(XMIN1,XSMINA)
+C mesonic particle
+ IF(IBAR1.EQ.0) THEN
+ IF(IHFLS(1).EQ.0) THEN
+ XPOT1(1) = PARMDL(62)
+ XMIN(1,1) = XSMIN1
+ XPOT1(2) = PARMDL(63)
+ XMIN(1,2) = XSMIN1
+ ELSE
+ XPOT1(1) = PARMDL(54)
+ XMIN(1,1) = XMMIN1
+ XPOT1(2) = PARMDL(55)
+ XMIN(1,2) = XMMIN1
+ ENDIF
+ DO 100 I=3-IVAL1,MSMAX
+ XPOT1(I) = PSMES
+ XMIN(1,I) = XSMIN1
+ 100 CONTINUE
+C baryonic particle
+ ELSE
+ IF(IHFLS(1).EQ.0) THEN
+ XPOT1(1) = PARMDL(62)
+ XMIN(1,1) = XSMIN1
+ XPOT1(2) = PARMDL(63)
+ XMIN(1,2) = XSMIN1
+ ELSE
+ XPOT1(1) = PARMDL(50)
+ XMIN(1,1) = XBMIN1
+ XPOT1(2) = PARMDL(51)
+ XMIN(1,2) = XMMIN1
+ ENDIF
+ DO 200 I=3-IVAL1,MSMAX
+ XPOT1(I) = PSBAR
+ XMIN(1,I) = XSMIN1
+ 200 CONTINUE
+ ENDIF
+
+C particle 2
+ XMMIN2 = MAX(XMIN2,XMMINA)
+ XBMIN2 = MAX(XMIN2,XBMINA)
+ XSMIN2 = MAX(XMIN2,XSMINA)
+C mesonic particle
+ IF(IBAR2.EQ.0) THEN
+ IF(IHFLS(2).EQ.0) THEN
+ XPOT2(1) = PARMDL(62)
+ XMIN(2,1) = XSMIN2
+ XPOT2(2) = PARMDL(63)
+ XMIN(2,2) = XSMIN2
+ ELSE
+ XPOT2(1) = PARMDL(54)
+ XMIN(2,1) = XMMIN2
+ XPOT2(2) = PARMDL(55)
+ XMIN(2,2) = XMMIN2
+ ENDIF
+ DO 300 I=3-IVAL2,MSMAX
+ XPOT2(I) = PSMES
+ XMIN(2,I) = XSMIN2
+ 300 CONTINUE
+C baryonic particle
+ ELSE
+ IF(IHFLS(2).EQ.0) THEN
+ XPOT2(1) = PARMDL(62)
+ XMIN(2,1) = XSMIN2
+ XPOT2(2) = PARMDL(63)
+ XMIN(2,2) = XSMIN2
+ ELSE
+ XPOT2(1) = PARMDL(50)
+ XMIN(2,1) = XBMIN2
+ XPOT2(2) = PARMDL(51)
+ XMIN(2,2) = XMMIN2
+ ENDIF
+ DO 400 I=3-IVAL2,MSMAX
+ XPOT2(I) = PSBAR
+ XMIN(2,I) = XSMIN2
+ 400 CONTINUE
+ ENDIF
+
+ XSS1 = XSUM1
+ XSS2 = XSUM2
+ MSOFT = MSMAX
+
+C check limits (important for valences)
+ IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
+ IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
+
+ XMINS1 = XSS1
+ IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
+ XMINS2 = XSS2
+ IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
+ DO 10 I=1,MSOFT
+ XMINS1 = XMINS1+XMIN(1,I)
+ XMINS2 = XMINS2+XMIN(2,I)
+ 10 CONTINUE
+ IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
+
+C try to sample x values
+ IF(IPAMDL(14).EQ.0) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE IF(MSOFT.LT.5) THEN
+ CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE IF(IPAMDL(14).EQ.1) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE IF(IPAMDL(14).EQ.2) THEN
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE IF(IPAMDL(14).EQ.3) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE IF(IVAL1+IVAL2.EQ.0) THEN
+ CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE
+ WRITE(LO,'(/,1X,A,I3)')
+ & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
+ STOP
+ ENDIF
+ IF(IREJ.NE.0) THEN
+ IFAIL(41) = IFAIL(41)+1
+ IF(IDEB(60).GE.2) THEN
+ WRITE(LO,'(1X,A,I12,4I3)')
+ & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
+ & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
+ WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
+ & XSUM1,XSUM2,XMAX1,XMAX2
+ ENDIF
+ RETURN
+ ENDIF
+ IF(MSOFT.NE.MSMAX) THEN
+ MSDIFF = MSMAX-MSOFT
+ MSPAR1 = MSPAR1-MSDIFF
+ MSPAR2 = MSPAR2-MSDIFF
+ ENDIF
+
+C correct for different MSPAR numbers
+ IF(MSOFT.NE.MSPAR1) THEN
+ IF(MSPAR1.GT.1) THEN
+ XDEL = 0.D0
+ DO 500 I=MSPAR1+1,MSOFT
+ XDEL = XDEL+XS1(I)
+ 500 CONTINUE
+ XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
+ DO 550 I=2,MSPAR1
+ XS1(I) = XS1(I)*XFAC
+ 550 CONTINUE
+ XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
+ ELSE
+ XSS1 = XSUM1
+ ENDIF
+ ENDIF
+ IF(MSOFT.NE.MSPAR2) THEN
+ IF(MSPAR2.GT.1) THEN
+ XDEL = 0.D0
+ DO 600 I=MSPAR2+1,MSOFT
+ XDEL = XDEL+XS2(I)
+ 600 CONTINUE
+ XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
+ DO 650 I=2,MSPAR2
+ XS2(I) = XS2(I)*XFAC
+ 650 CONTINUE
+ XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
+ ELSE
+ XSS2 = XSUM2
+ ENDIF
+ ENDIF
+
+C first x entry
+ XS1(1) = 1.D0 - XSS1
+ XS2(1) = 1.D0 - XSS2
+ XSUM1 = XSS1
+ XSUM2 = XSS2
+
+C debug output
+ IF(IDEB(60).GE.10) THEN
+ WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
+ & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
+ & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
+ WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
+ DO 30 I=1,MSOFT
+ WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
+ & XMIN(1,I),XMIN(2,I)
+ 30 CONTINUE
+ ENDIF
+
+ RETURN
+
+C not enough phase space
+ 1000 CONTINUE
+
+ IFAIL(42) = IFAIL(42)+1
+ IREJ = 1
+
+C warning message
+ IF(IDEB(60).GE.1) THEN
+ WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
+ & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
+ & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
+ & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
+ WRITE(LO,'(1X,A)')
+ & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
+ DO 27 I=1,MSOFT
+ WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
+ 27 CONTINUE
+ WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
+ & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
+ & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
+ WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
+ DO 25 I=1,MSOFT
+ WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
+ & XMIN(1,I),XMIN(2,I)
+ 25 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SELSXR.FOR
+*COPY PHO_SELSXR
+CDECK ID>, PHO_SELSXR
+ SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (rejection method)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IF(IDEB(13).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
+ WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
+ & MSOFT,XS1,XS2,XMAX1,XMAX2
+ DO 40 I=1,MSOFT
+ WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
+ 40 CONTINUE
+ ENDIF
+C
+ IREJ = 0
+C
+ XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
+ XMIN1 = MAX(AS/XMAX1,XMINK)
+ XMIN2 = MAX(AS/XMAX2,XMINK)
+C
+ IF(MSOFT.EQ.1) THEN
+ XSOFT1(2) = 0.D0
+ XSOFT2(2) = 0.D0
+ RETURN
+ ENDIF
+ XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
+ & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
+C
+ 10 CONTINUE
+C
+ DO 50 I=2,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+C
+ ITRY0 = 0
+ 5 CONTINUE
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(181)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XREST1 = 1.D0-XS1
+ XREST2 = 1.D0-XS2
+ DO 100 I=2,MSOFT
+ ITRY1 = 0
+
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+
+ XREST1 = XREST1-XSOFT1(I)
+ IF(XREST1.LT.XMIN1) GOTO 5
+ IF(XREST1.LT.XMIN(1,1)) GOTO 5
+ XREST2 = XREST2-XSOFT2(I)
+ IF(XREST2.LT.XMIN2) GOTO 5
+ IF(XREST2.LT.XMIN(2,1)) GOTO 5
+ IF(XREST1*XREST2.LT.AS) GOTO 5
+
+ 100 CONTINUE
+ XSOFT1(1) = XREST1
+ XSOFT2(1) = XREST2
+ IREJ=0
+* XX = 1.D0
+* DO 200 I=2,MSOFT
+* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
+*200 CONTINUE
+ XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
+ IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
+
+ XS1 = 1.D0-XREST1
+ XS2 = 1.D0-XREST2
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(13).GE.2) THEN
+ WRITE(LO,'(1X,A,2I4)')
+ & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
+ WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SELSX2.FOR
+*COPY PHO_SELSX2
+CDECK ID>, PHO_SELSX2
+ SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
+ & XS1,XS2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends using PHO_RNDBET
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ IREJ = 0
+
+ IF(IDEB(32).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
+ WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
+ & AS,XSUM1,XSUM2,XMAX1,XMAX2
+ DO 30 I=1,2
+ WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
+ 30 CONTINUE
+ ENDIF
+
+ FAC1 = 1.D0-XSUM1
+ FAC2 = 1.D0-XSUM2
+ FAC = FAC1*FAC2
+ GAM1 = XPOT1(1)+1.D0
+ GAM2 = XPOT2(1)+1.D0
+ BET1 = XPOT1(2)+1.D0
+ BET2 = XPOT2(2)+1.D0
+
+ ITRY0 = 0
+ DO 100 I=1,IPAMDL(182)
+
+ ITRY1 = 0
+ 10 CONTINUE
+ X1 = PHO_RNDBET(GAM1,BET1)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
+
+ ITRY2 = 0
+ 11 CONTINUE
+ X2 = PHO_RNDBET(GAM2,BET2)
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GE.50) GOTO 1000
+ IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
+
+ X3 = 1.D0 - X1
+ X4 = 1.D0 - X2
+ IF(X1*X2*FAC.GT.AS) THEN
+ IF(X3*X4*FAC.GT.AS) THEN
+ XS1(1) = X1*FAC1
+ XS1(2) = X3*FAC1
+ XS2(1) = X2*FAC2
+ XS2(2) = X4*FAC2
+ IF(XS1(1).GT.XMIN(1,1)) THEN
+ IF(XS2(1).GT.XMIN(2,1)) THEN
+ IF(XS1(2).GT.XMIN(1,2)) THEN
+ IF(XS2(2).GT.XMIN(2,2)) THEN
+ XSUM1 = XSUM1+XS1(2)
+ XSUM2 = XSUM2+XS2(2)
+ GOTO 300
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ITRY0 = ITRY0+1
+
+ 100 CONTINUE
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(32).GE.2) THEN
+ WRITE(LO,'(1X,A,3I4)')
+ & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
+ WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
+ ENDIF
+ RETURN
+ 300 CONTINUE
+
+ END
+
+*$ CREATE PHO_SELSXS.FOR
+*COPY PHO_SELSXS
+CDECK ID>, PHO_SELSXS
+ SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (rescaling method)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IREJ = 0
+
+ 10 CONTINUE
+
+ IF(MSOFT.EQ.1) THEN
+ XSOFT1(1) = 1.D0-XS1
+ XSOFT1(2) = 0.D0
+ XSOFT2(1) = 1.D0-XS2
+ XSOFT2(2) = 0.D0
+ RETURN
+ ENDIF
+
+ DO 50 I=1,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+
+ ITRY0 = 0
+ 5 CONTINUE
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(180)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT= MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XSUM1 = 0.D0
+ XSUM2 = 0.D0
+ DO 100 I=1,MSOFT
+ ITRY1 = 0
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+ XSUM1 = XSUM1+XSOFT1(I)
+ XSUM2 = XSUM2+XSOFT2(I)
+ 100 CONTINUE
+ FAC1 = (1.D0-XS1)/XSUM1
+ FAC2 = (1.D0-XS2)/XSUM2
+ DO 200 I=1,MSOFT
+ XSOFT1(I) = XSOFT1(I)*FAC1
+ XSOFT2(I) = XSOFT2(I)*FAC2
+ IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
+ IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
+ IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
+ 200 CONTINUE
+
+ XS1 = 1.D0-XSOFT1(1)
+ XS2 = 1.D0-XSOFT2(1)
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(14).GE.2) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
+ & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
+ DO 300 I=1,MSOFT
+ WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
+ 300 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SELSXI.FOR
+*COPY PHO_SELSXI
+CDECK ID>, PHO_SELSXI
+ SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (sea independent from valence)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IREJ = 0
+
+ 10 CONTINUE
+
+ DO 50 I=1,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+
+C selection of sea
+ ITRY0 = 0
+ 5 CONTINUE
+
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(183)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XSUM1 = XS1
+ XSUM2 = XS2
+ DO 100 I=3,MSOFT
+ ITRY1 = 0
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+ XSUM1 = XSUM1+XSOFT1(I)
+ XSUM2 = XSUM2+XSOFT2(I)
+ 100 CONTINUE
+
+ IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
+ IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
+
+C selection of valence
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
+ & XSOFT1,XSOFT2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
+ & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
+ & XSUM1,XSUM2,XMAX1,XMAX2
+ RETURN
+ ENDIF
+
+ XS1 = 1.D0-XSOFT1(1)
+ XS2 = 1.D0-XSOFT2(1)
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(14).GE.2) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
+ & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
+ DO 300 I=1,MSOFT
+ WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
+ 300 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SELCOL.FOR
+*COPY PHO_SELCOL
+CDECK ID>, PHO_SELCOL
+ SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
+C********************************************************************
+C
+C color combinatorics
+C
+C input: ICO1,2 colors of incoming particle
+C IMODE -2 output of initialization status
+C -1 initialization
+C ICINP(1) selection mode
+C 0 QCD
+C 1 large N_c expansion
+C ICINP(2) max. allowed color
+C 0 clear internal color counter
+C 1 hadron into two colored objects
+C 2 quark into quark gluon
+C 3 gluon into gluon gluon
+C 4 gluon into quark antiquark
+C
+C output: ICOA1,2 colors of first outgoing particle
+C ICOB1,2 colors of second outgoing particle
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+ DATA METHOD /0/, II /0/
+
+ ICI1 = ICO1
+ ICI2 = ICO2
+ IF(METHOD.EQ.0) THEN
+
+ IF(IMODE.EQ.1) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ ICOA1 = II
+ ICOA2 = 0
+ ICOB1 = -II
+ ICOB2 = 0
+ ELSE IF(IMODE.EQ.2) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ ICOA2 = 0
+ IF(ICI1.GT.0) THEN
+ ICOA1 = II
+ ICOB1 = ICI1
+ ICOB2 = -II
+ ELSE
+ ICOA1 = -II
+ ICOB1 = II
+ ICOB2 = ICI1
+ ENDIF
+ ELSE IF(IMODE.EQ.3) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ IF(DT_RNDM(DUM).GT.0.5D0) THEN
+ ICOA1 = ICI1
+ ICOA2 = -II
+ ICOB1 = II
+ ICOB2 = ICI2
+ ELSE
+ ICOB1 = ICI1
+ ICOB2 = -II
+ ICOA1 = II
+ ICOA2 = ICI2
+ ENDIF
+ ELSE IF(IMODE.EQ.4) THEN
+ ICOA1 = ICI1
+ ICOA2 = 0
+ ICOB1 = ICI2
+ ICOB2 = 0
+ ELSE IF(IMODE.EQ.0) THEN
+ II = 0
+ ELSE IF(IMODE.EQ.-1) THEN
+ METHOD = ICI1
+ MAXCOL = ICI2
+ ELSE IF(IMODE.EQ.-2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
+ & METHOD,MAXCOL
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
+ CALL PHO_ABORT
+ ENDIF
+
+ II = ABS(II)
+ IF(IDEB(75).GE.10) THEN
+ WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
+ & IMODE,MAXCOL,II
+ WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
+ WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
+ ENDIF
+
+ END
+
+*$ CREATE ipho_diqu.FOR
+*COPY ipho_diqu
+CDECK ID>, ipho_diqu
+ INTEGER FUNCTION ipho_diqu(iq1,iq2)
+C***********************************************************************
+C
+C selection of diquark number (PDG convention)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer iq1,iq2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C external functions
+ double precision DT_RNDM
+
+C local variables
+ integer i0,i1,i2
+ double precision dum
+
+ i1 = abs(iq1)
+ i2 = abs(iq2)
+
+ if(i1.eq.i2) then
+ i0 = i1*1100+3
+ else
+ i0 = max(i1,i2)*1000+min(i1,i2)*100
+ if(DT_RNDM(dum).gt.PARMDL(135)) then
+ i0 = i0+1
+ else
+ i0 = i0+3
+ endif
+ endif
+
+ ipho_diqu = sign(i0,iq1)
+
+ END
+
+*$ CREATE PHO_PARREM.FOR
+*COPY PHO_PARREM
+CDECK ID>, PHO_PARREM
+ SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
+C**********************************************************************
+C
+C selection of particle remnant flavour(s) (quark or diquark)
+C
+C input: INDX index of particle in /POEVT1/
+C IOUT parton which was taken out
+C
+C output: IREM remnant according to valence flavours
+C IREJ 0 flavour combination possible
+C 1 flavour combination impossible
+C
+C all particle ID are given according to PDG conventions
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer INDX,IOUT,IREM,IREJ
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_diqu
+
+C local variables
+ integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
+ dimension IQUA(3),IDQ(2)
+
+ ID1 = IDHEP(INDX)
+ ID2 = IMPART(INDX)
+ IREJ = 0
+
+ IF(ID2.EQ.0) THEN
+ WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
+ CALL PHO_ABORT
+ ENDIF
+
+C particle with flavour mixing
+ if(ID1.eq.22) then
+C photon
+ IREM = -IOUT
+ GOTO 100
+ else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
+C pi0, rho0, and omega
+ IF(ABS(IOUT).LE.2) THEN
+ IREM = -IOUT
+ GOTO 100
+ ELSE
+ GOTO 150
+ ENDIF
+ else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
+C neutral kaons (K0,K0-bar)
+ if(abs(IOUT).eq.1) then
+ IREM = sign(3,-IOUT)
+ goto 100
+ else if(abs(IOUT).eq.3) then
+ IREM = sign(1,-IOUT)
+ goto 100
+ else
+ goto 150
+ endif
+ else if((ID1.eq.990).or.(ID1.eq.110)) then
+C pomeron and reggeon
+ IREM = -IOUT
+ GOTO 100
+ endif
+
+C ordinary hadron
+ ID = abs(ID2)
+ IS = sign(1,ID2)
+ IQUA(1) = iq_list(1,ID)*IS
+ IQUA(2) = iq_list(2,ID)*IS
+ IQUA(3) = iq_list(3,ID)*IS
+
+C compare to flavour content
+ IF(ABS(IOUT).LT.1000) THEN
+C single quark requested
+ IF(IQUA(1).EQ.IOUT) THEN
+ K1 = 2
+ K2 = 3
+ ELSE IF(IQUA(2).EQ.IOUT) THEN
+ K1 = 1
+ K2 = 3
+ ELSE IF(IQUA(3).EQ.IOUT) THEN
+ K1 = 1
+ K2 = 2
+ ELSE
+ GOTO 150
+ ENDIF
+ IF(IQUA(3).EQ.0) THEN
+ IREM = IQUA(K1)
+ ELSE
+ IREM = ipho_diqu(IQUA(K1),IQUA(K2))
+ ENDIF
+ ELSE IF(IQUA(3).NE.0) THEN
+C diquark requested from baryon
+ IDQ(1) = IOUT/1000
+ IDQ(2) = (IOUT-IDQ(1)*1000)/100
+ do i=1,2
+ do k=1,3
+ if(IDQ(i).eq.IQUA(k)) then
+ IQUA(k) = 0
+ goto 110
+ endif
+ enddo
+ goto 150
+ 110 continue
+ enddo
+ IREM = IQUA(1)+IQUA(2)+IQUA(3)
+ ENDIF
+
+ 100 CONTINUE
+C debug output
+ IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
+ & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
+ & INDX,ID1,ID2,IOUT,IREM
+ RETURN
+
+C rejection
+ 150 CONTINUE
+ IREJ = 1
+ IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
+ & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
+
+ END
+
+*$ CREATE PHO_VALFLA.FOR
+*COPY PHO_VALFLA
+CDECK ID>, PHO_VALFLA
+ SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
+C***********************************************************************
+C
+C selection of valence flavour decomposition of particle IPAR
+C
+C input: IPAR particle index in /POEVT1/
+C -1 initialization
+C -2 output of statistics
+C XMASS mass of particle
+C (important for pomeron:
+C mass dependent flavour sampling)
+C
+C output: IFL1,IFL2
+C baryon: IFL1 diquark flavour
+C (valence flavours according to PDG conventions)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ data ITMX / 5 /
+
+ IF(IPAR.GT.0) THEN
+ K = IPAR
+C select particle code
+ ID1 = IDHEP(K)
+ ID = abs(IMPART(K))
+ IBAR = IPHO_BAR3(K,2)
+ ITER = 0
+
+ 10 CONTINUE
+
+ ifl1 = 0
+ ifl2 = 0
+ ITER = ITER+1
+ if(ITER.GT.ITMX) then
+ WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
+ & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
+ return
+ endif
+
+C not baryon
+ IF(IBAR.EQ.0) THEN
+
+C photon
+ IF(ID1.EQ.22) THEN
+C charge dependent flavour sampling
+ 15 CONTINUE
+ K = INT(DT_RNDM(E1)*6.D0)+1
+ IF(K.LE.4) THEN
+ IFL1 = 2
+ IFL2 = -2
+ ELSE IF(K.EQ.5) THEN
+ IFL1 = 1
+ IFL2 = -1
+ ELSE
+ IFL1 = 3
+ IFL2 = -3
+ ENDIF
+C optional strangeness suppression
+ IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
+ IF(DT_RNDM(DUM).LT.0.5D0) THEN
+ K = IFL1
+ IFL1 = IFL2
+ IFL2 = K
+ ENDIF
+
+C pomeron, reggeon
+ ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
+ IF(ISWMDL(19).EQ.0) THEN
+C SU(3) symmetric valences
+ K = INT(DT_RNDM(E1)*3.D0)+1
+ IF(DT_RNDM(DUM).LT.0.5D0) THEN
+ IFL1 = K
+ ELSE
+ IFL1 = -K
+ ENDIF
+ IFL2 = -IFL1
+ ELSE IF(ISWMDL(19).EQ.1) THEN
+C mass dependent flavour sampling
+ EMIN = MIN(E1,E2)
+ CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
+ ELSE
+ WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
+ & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
+ CALL PHO_ABORT
+ ENDIF
+
+C meson with flavour mixing
+ ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
+ K = INT(2.D0*DT_RNDM(E1))+1
+ IFL1 = K
+ IFL2 = -K
+C meson (standard)
+ ELSE
+ K = INT(2.D0*DT_RNDM(E1))+1
+ IFL1 = iq_list(K,ID)
+ K = MOD(K,2) + 1
+ IFL2 = iq_list(K,ID)
+ if(IFL1.EQ.0) then
+ EMIN = MIN(E1,E2)
+ CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
+ endif
+ ENDIF
+
+C baryon
+ ELSE
+ K = INT(2.999999D0*DT_RNDM(E2))+1
+ K1 = MOD(K,3)+1
+ K2 = MOD(K1,3)+1
+ IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
+ IFL2 = iq_list(K,ID)
+ ENDIF
+
+C change sign for antiparticles
+ if(ID1.lt.0) then
+ IFL1 = -IFL1
+ IFL2 = -IFL2
+ endif
+
+************************************************************************
+C check kinematic constraints
+* IF((PHO_PMASS(IFL1,3).GT.E1)
+* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
+************************************************************************
+
+C debug output
+ IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
+ & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
+
+ ELSE IF(IPAR.EQ.-1) THEN
+C initialization
+
+ ELSE IF(IPAR.EQ.-2) THEN
+C output of final statistics
+
+ ELSE
+ WRITE(LO,'(1X,A,I10)')
+ & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_REGFLA.FOR
+*COPY PHO_REGFLA
+CDECK ID>, PHO_REGFLA
+ SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
+C**********************************************************************
+C
+C selection of reggeon flavours
+C
+C input: JM1,JM2 position index of mother hadrons
+C
+C output: IFLR1,IFLR2 valence flavours according to
+C PDG conventions and JM1,JM2
+C IREJ 0 reggeon possible
+C 1 reggeon impossible
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ IF(JM1.GT.0) THEN
+ IREJ = 0
+ ITER = 0
+C available energy
+ E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
+ & -(PHEP(1,JM1)+PHEP(1,JM2))**2
+ & -(PHEP(2,JM1)+PHEP(2,JM2))**2
+ & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GT.50) THEN
+ IREJ = 1
+C debug output
+ IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
+ & 'PHO_REGFLA: rejection, no reggeon found for',
+ & IDHEP(JM1),IDHEP(JM2),E1
+ RETURN
+ ENDIF
+
+ CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
+ CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
+ IF(IFLA1.EQ.-IFLB1) THEN
+ IFLR1 = IFLA2
+ IFLR2 = IFLB2
+ ELSE IF(IFLA1.EQ.-IFLB2) THEN
+ IFLR1 = IFLA2
+ IFLR2 = IFLB1
+ ELSE IF(IFLA2.EQ.-IFLB1) THEN
+ IFLR1 = IFLA1
+ IFLR2 = IFLB2
+ ELSE IF(IFLA2.EQ.-IFLB2) THEN
+ IFLR1 = IFLA1
+ IFLR2 = IFLB1
+ ELSE
+C debug output
+ IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
+ & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
+ GOTO 50
+ ENDIF
+C debug output
+ IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
+ & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
+ & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
+ ELSE IF(JM1.EQ.-1) THEN
+C initialization
+ ELSE IF(JM1.EQ.-2) THEN
+C output of statistics
+ ELSE
+ WRITE(LO,'(1X,A,I10)')
+ & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SEAFLA.FOR
+*COPY PHO_SEAFLA
+CDECK ID>, PHO_SEAFLA
+ SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
+C**********************************************************************
+C
+C selection of sea flavour content of particle IPAR
+C
+C input: IPAR particle index in /POEVT1/
+C CHMASS available invariant string mass
+C positive mass --> use BAMJET method
+C negative mass --> SU(3) symmetric sea according
+C to values given in PARMDL(1-6)
+C IPAR -1 initialization
+C -2 output of statistics
+C
+C output: sea flavours according to PDG conventions
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ IF(IPAR.GT.0) THEN
+ IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
+C constant weights for sea
+ 15 CONTINUE
+ SUM = 0.D0
+ DO 40 K=1,NFSEA
+ SUM = SUM + PARMDL(K)
+ 40 CONTINUE
+ XI = DT_RNDM(SUM)*SUM
+ SUM = 0.D0
+ DO 50 K=1,NFSEA
+ SUM = SUM + PARMDL(K)
+ IF(XI.LE.SUM) GOTO 55
+ 50 CONTINUE
+ 55 CONTINUE
+ IF(K.GT.NFSEA) GOTO 15
+ ELSE
+C mass dependent flavour sampling
+ 10 CONTINUE
+ CALL PHO_FLAUX(CHMASS,K)
+ IF(K.GT.NFSEA) GOTO 10
+ ENDIF
+ IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
+ IFL1 = K
+ IFL2 = -K
+ IF(IDEB(46).GE.10) THEN
+ WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
+ & IPAR,IFL1,IFL2,CHMASS
+ ENDIF
+ ELSE IF(IPAR.EQ.-1) THEN
+C initialization
+ NFSEA = NFS
+ ELSE IF(IPAR.EQ.-2) THEN
+C output of statistics
+ ELSE
+ WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_FLAUX.FOR
+*COPY PHO_FLAUX
+CDECK ID>, PHO_FLAUX
+ SUBROUTINE PHO_FLAUX(EQUARK,K)
+C***********************************************************************
+C
+C auxiliary subroutine to select flavours
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-14 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ DIMENSION WGHT(9)
+
+C calculate weights for given energy
+ IF(EQUARK.LT.QMASS(1)) THEN
+ IF(IDEB(16).GE.5)
+ & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
+ & EQUARK
+ WGHT(1) = 0.5D0
+ WGHT(2) = 0.5D0
+ WGHT(3) = 0.D0
+ WGHT(4) = 0.D0
+ SUM = 1.D0
+ ELSE
+ SUM = 0.D0
+ DO 305 K=1,NFS
+ IF(EQUARK.GT.QMASS(K)) THEN
+ WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
+ ELSE
+ WGHT(K) = 0.D0
+ ENDIF
+ SUM = SUM + WGHT(K)
+ 305 CONTINUE
+ ENDIF
+C sample flavours
+ XI = SUM*(DT_RNDM(SUM)-DEPS)
+ K = 0
+ SUM = 0.D0
+ 400 CONTINUE
+ K = K+1
+ SUM = SUM + WGHT(K)
+ IF(XI.GT.SUM) GOTO 400
+C debug output
+ IF(IDEB(16).GE.20) THEN
+ WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
+ ENDIF
+ END
+
+*$ CREATE PHO_BETAF.FOR
+*COPY PHO_BETAF
+CDECK ID>, PHO_BETAF
+ DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
+C********************************************************************
+C
+C weights of different quark flavours
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX=0.D0
+ BETX1=BET*X1
+ IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
+ AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
+
+ PHO_BETAF=AX+AY
+
+ END
+
+*$ CREATE PHO_MCHECK.FOR
+*COPY PHO_MCHECK
+CDECK ID>, PHO_MCHECK
+ SUBROUTINE PHO_MCHECK(J1,IREJ)
+C********************************************************************
+C
+C check parton momenta for fragmentation
+C
+C input: J1 first string number
+C /POEVT1/
+C /POSTRG/
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C in case of very small string mass:
+C NNCH mass label of string
+C 0 string
+C -1 octett baryon / pseudo scalar meson
+C 1 decuplett baryon / vector meson
+C IBHAD hadron number according to CPC,
+C string will be treated as resonance
+C (sometimes far off mass shell)
+C
+C constant WIDTH ( 0.01GeV ) determines range of acceptance
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( WIDTH = 0.01D0,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+C quark antiquark jet
+ STRM = PHEP(5,NPOS(1,J1))
+ IF(NCODE(J1).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
+ & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
+ & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
+ IF(STRM.LT.AMPS) THEN
+ IREJ = 1
+ IFAIL(20) = IFAIL(20) + 1
+ RETURN
+ ELSE IF(STRM.LT.AMPS2) THEN
+ IF(STRM.LT.(AMVE-WIDTH)) THEN
+ NNCH(J1) = -1
+ IBHAD(J1) = IPS
+ ELSE
+ NNCH(J1) = 1
+ IBHAD(J1) = IVE
+ ENDIF
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+C quark diquark or v.s. jet
+ ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
+ & AM8,AM82,AM10,AM102,I8,I10)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
+ & J1,STRM,AM8,AM82,AM10,AM102
+ IF(STRM.LT.AM8) THEN
+ IREJ = 1
+ IFAIL(19) = IFAIL(19) + 1
+ RETURN
+ ELSE IF(STRM.LT.AM82) THEN
+ IF(STRM.LT.(AM10-WIDTH)) THEN
+ NNCH(J1) = -1
+ IBHAD(J1) = I8
+ ELSE
+ NNCH(J1) = 1
+ IBHAD(J1) = I10
+ ENDIF
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+C diquark a-diquark string
+ ELSE IF(NCODE(J1).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
+ & AM82,AM102)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
+ & J1,STRM,AM82,AM102
+ IF(STRM.LT.AM82) THEN
+ IREJ = 1
+ IFAIL(19) = IFAIL(19) + 1
+ RETURN
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+ ELSE IF(NCODE(J1).LT.0) THEN
+ RETURN
+ ELSE
+ WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
+ & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
+ CALL PHO_ABORT
+ ENDIF
+ END
+
+*$ CREATE PHO_POMCOR.FOR
+*COPY PHO_POMCOR
+CDECK ID>, PHO_POMCOR
+ SUBROUTINE PHO_POMCOR(IREJ)
+C********************************************************************
+C
+C join quarks to gluons in case of too small masses
+C
+C input: /POEVT1/
+C /POSTRG/
+C IREJ -1 initialization
+C -2 output of statistics
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+ DIMENSION PJ(4)
+
+ IF(IREJ.EQ.-1) THEN
+ ICTOT = 0
+ ICCOR = 0
+ RETURN
+ ELSE IF(IREJ.EQ.-2) THEN
+ WRITE(LO,'(/1X,A,2I8)')
+ & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
+ RETURN
+ ENDIF
+C
+ IREJ = 0
+C
+ NITER = 100
+ ITER = 0
+ ICTOT = ICTOT+ISTR
+ IF(ISWMDL(25).LE.0) RETURN
+C debug string entries
+ IF(IDEB(83).GE.25) CALL PHO_PRSTRG
+C
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.NITER) THEN
+ IREJ = 1
+ IF(IDEB(83).GE.2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
+ IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+C
+C check mass limits
+ ISTRO = ISTR
+ DO 100 I=1,ISTRO
+ IF(NCODE(I).LT.0) GOTO 99
+ J1 = NPOS(1,I)
+ NRPOM = IPHIST(2,J1)
+ IF(NRPOM.GE.100) GOTO 99
+ CMASS0 = PHEP(5,J1)
+C get masses
+ IF(NCODE(I).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
+ & AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF(NCODE(I).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
+ & AM1,AM2)
+ AM3 = 0.D0
+ AM4 = 0.D0
+ IP1 = 0
+ IP2 = 0
+ ELSE IF(NCODE(I).EQ.7) THEN
+ GOTO 99
+ ELSE IF(NCODE(I).LT.0) THEN
+ GOTO 99
+ ELSE
+ WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
+ & J1,NCODE(I)
+ CALL PHO_ABORT
+ ENDIF
+ IF(IDEB(83).GE.5)
+ & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
+ & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
+ & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
+C select masses to correct
+ IF(CMASS0.LT.MAX(AM2,AM4)) THEN
+ DO 200 K=1,ISTRO
+ IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
+ J2 = NPOS(1,K)
+C join quarks to gluon
+ IF(NRPOM.EQ.IPHIST(2,J2)) THEN
+C flavour check
+ IFL1 = 0
+ IFL2 = 0
+ PROB1 = 0.D0
+ PROB2 = 0.D0
+ KK1 = NPOS(2,I)
+ KK2 = NPOS(2,K)
+ IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
+ CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
+ & -(PHEP(1,KK1)+PHEP(1,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ IFL1 = ABS(IDHEP(KK1))
+ IF(IFL1.GT.2) THEN
+ PROB1 = 0.1D0/MAX(CMASS,EPS)
+ ELSE
+ PROB1 = 0.9D0/MAX(CMASS,EPS)
+ ENDIF
+ ENDIF
+ KK1 = ABS(NPOS(3,I))
+ KK2 = ABS(NPOS(3,K))
+ IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
+ CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
+ & -(PHEP(1,KK1)+PHEP(1,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ IFL2 = ABS(IDHEP(KK1))
+ IF(IFL2.GT.2) THEN
+ PROB2 = 0.1D0/MAX(CMASS,EPS)
+ ELSE
+ PROB2 = 0.9D0/MAX(CMASS,EPS)
+ ENDIF
+ ENDIF
+ IF(IFL1+IFL2.EQ.0) GOTO 99
+C fusion possible
+ ICCOR = ICCOR+1
+ IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
+ JJ = 2
+ JE = 3
+ ELSE
+ JJ = 3
+ JE = 2
+ ENDIF
+ KK1 = ABS(NPOS(JJ,I))
+ KK2 = ABS(NPOS(JJ,K))
+ I1 = ABS(NPOS(JE,I))
+ I2 = KK1
+ IS = SIGN(1,I2-I1)
+ I2 = I2 - IS
+ K1 = KK2
+ K2 = ABS(NPOS(JE,K))
+ KS = SIGN(1,K2-K1)
+ K1 = K1 + KS
+ IP1 = NHEP+1
+C copy mother partons of string I
+ DO 300 II=I1,I2,IS
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
+ & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
+ & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
+ 300 CONTINUE
+C register gluon
+ DO 350 II=1,4
+ PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
+ 350 CONTINUE
+ CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
+ & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
+C copy mother partons of string K
+ DO 400 II=K1,K2,KS
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
+ & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
+ & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
+ 400 CONTINUE
+C create new string entry
+ DO 450 II=1,4
+ PJ(II) = PHEP(II,J1)+PHEP(II,J2)
+ 450 CONTINUE
+ IP2 = IPOS
+ CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
+ & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
+ & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
+C delete string K in /POSTRG/
+ NCODE(K) = -999
+C update string I in /POSTRG/
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = IP1
+ NPOS(3,I) = -IP2
+C calculate new CPC string codes
+ CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
+ & IPAR2(I),IPAR3(I),IPAR4(I))
+ GOTO 99
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+ ENDIF
+ 99 CONTINUE
+ 100 CONTINUE
+ IF(IDEB(83).GE.20) THEN
+ WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
+ IF(IDEB(83).GE.22) THEN
+ CALL PHO_PRSTRG
+ CALL PHO_PREVNT(0)
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_MASCOR.FOR
+*COPY PHO_MASCOR
+CDECK ID>, PHO_MASCOR
+ SUBROUTINE PHO_MASCOR(IREJ)
+C********************************************************************
+C
+C check and adjust parton momenta for fragmentation
+C
+C input: /POEVT1/
+C /POSTRG/
+C IREJ -1 initialization
+C -2 output of statistics
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C in case of very small string mass:
+C - direct manipulation of /POEVT1/ and /POEVT2/
+C - string will be deleted from /POSTRG/ (label -99)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10,
+ & EMIN = 0.3D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+ DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
+
+ IF(IREJ.EQ.-1) THEN
+ ICTOT = 0
+ ICCOR = 0
+ RETURN
+ ELSE IF(IREJ.EQ.-2) THEN
+ WRITE(LO,'(/1X,A,2I8/)')
+ & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
+ RETURN
+ ENDIF
+
+ IREJ = 0
+ NITER = 100
+ ITER = 0
+ ICTOT = ICTOT+ISTR
+ IF(ISWMDL(7).EQ.-1) RETURN
+C debug /POSTRG/
+ IF(IDEB(42).GE.25) CALL PHO_PRSTRG
+
+ ITOUCH = 0
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.NITER) THEN
+ IREJ = 1
+ IF(IDEB(42).GE.2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
+ IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+
+C check mass limits
+ IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
+ IM1 = 1
+ IM2 = ISTR
+ IST = 1
+ ELSE
+ IM1 = ISTR
+ IM2 = 1
+ IST = -1
+ ENDIF
+ DO 100 I=IM1,IM2,IST
+ J1 = NPOS(1,I)
+ CMASS0 = PHEP(5,J1)
+C get masses
+ IF(NCODE(I).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
+ & AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF(NCODE(I).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
+ & AM1,AM2)
+ AM3 = 0.D0
+ AM4 = 0.D0
+ IP1 = 0
+ IP2 = 0
+ ELSE IF(NCODE(I).EQ.7) THEN
+ AM1 = 0.15D0
+ AM2 = 0.3D0
+ AM3 = 0.765D0
+ AM4 = 1.5D0
+*??????????????????????????????????
+ IP1 = 23
+ IP2 = 33
+*??????????????????????????????????
+ ELSE IF(NCODE(I).LT.0) THEN
+ GOTO 90
+ ELSE
+ WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
+ & J1,NCODE(I)
+ CALL PHO_ABORT
+ ENDIF
+ IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
+ & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
+ & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
+C select masses to correct
+ IBHAD(I) = 0
+ NNCH(I) = 0
+C correction needed?
+C no resonances for diquark-antidiquark and gluon-gluon strings
+ IF(NCODE(I).EQ.5) THEN
+ IF(CMASS0.LT.1.3D0*AM1) THEN
+ IF(ISWMDL(7).LE.2) THEN
+ IBHAD(I) = 90
+ NNCH(I) = -1
+ CHMASS = AM1*1.3D0
+ ELSE
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ INEED = 0
+C resonances possible
+ IF(ISWMDL(7).EQ.0) THEN
+ IF(CMASS0.LT.AM1*0.99D0) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ INEED = 1
+ ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
+ DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
+ DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
+ IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ ELSE
+ IBHAD(I) = IP2
+ NNCH(I) = 1
+ CHMASS = AM3
+ ENDIF
+ ENDIF
+ ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
+ IF(CMASS0.LT.AM1*0.99) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ INEED = 1
+ ENDIF
+ ELSE IF(ISWMDL(7).EQ.3) THEN
+ IF(CMASS0.LT.AM1) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+C correction necessary?
+ IF(IBHAD(I).NE.0) THEN
+C find largest invar. mass
+ IPOS = 0
+ CMASS1 = -1.D0
+ DO 200 J2=NHEP,3,-1
+
+ IF(ABS(ISTHEP(J2)).EQ.1) THEN
+ IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
+ WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
+ & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
+ CALL PHO_PREVNT(0)
+ ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
+ CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
+ & -(PHEP(1,J1)+PHEP(1,J2))**2
+ & -(PHEP(2,J1)+PHEP(2,J2))**2
+ & -(PHEP(3,J1)+PHEP(3,J2))**2
+ IF(CMASS2.GT.CMASS1) THEN
+ IPOS=J2
+ CMASS1=CMASS2
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 200 CONTINUE
+ J2 = IPOS
+ IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
+ IF(INEED.EQ.1) THEN
+ IREJ = 1
+ RETURN
+ ELSE
+ IBHAD(I) = 0
+ NNCH(I) = 0
+ GOTO 90
+ ENDIF
+ ENDIF
+ ISTA = ISTHEP(J1)
+ ISTB = ISTHEP(J2)
+ CMASS1 = SQRT(CMASS1)
+ CMASS2 = PHEP(5,J2)
+ IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
+ IREJ = 1
+ IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
+ & CHMASS,CMASS2,PC1,PC2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(24) = IFAIL(24)+1
+ IF(IDEB(42).GE.2) THEN
+ WRITE(LO,'(1X,A,2I4)')
+ & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
+ IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+C momentum transfer
+ DO 210 II=1,4
+ PTR(II) = PHEP(II,J2)-PC2(II)
+ 210 CONTINUE
+ IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
+ & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
+C copy parents of strings
+C register partons belonging to first string
+ IF(IDHEP(J1).EQ.90) THEN
+ K1 = JMOHEP(1,J1)
+ K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
+ ESUM = 0.D0
+ DO 500 II=K1,K2
+ ESUM = ESUM+PHEP(4,II)
+ 500 CONTINUE
+ IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
+ DO 600 II=K1,K2
+ FAC = PHEP(4,II)/ESUM
+ DO 650 K=1,4
+ P1(K) = PHEP(K,II)+FAC*PTR(K)
+ 650 CONTINUE
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ 600 CONTINUE
+ K1A = IPOS+K1-K2
+ IF(JMOHEP(2,J1).GT.0) THEN
+ II = JMOHEP(2,J1)
+ FAC = PHEP(4,II)/ESUM
+ DO 675 K=1,4
+ P1(K) = PHEP(K,II)+FAC*PTR(K)
+ 675 CONTINUE
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ ENDIF
+ K2A = -IPOS
+ ELSE
+ K1A = J1
+ K2A = J2
+ ENDIF
+C register partons belonging to second string
+ IF(IDHEP(J2).EQ.90) THEN
+ CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
+ K1 = JMOHEP(1,J2)
+ K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
+ ESUM = 0.D0
+ DO 300 II=K1,K2
+ ESUM = ESUM+PHEP(4,II)
+ 300 CONTINUE
+ IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
+ DO 400 II=K1,K2
+**sr 28.12.2006 fix adopted from FLUKA
+C FAC = PHEP(4,II)/ESUM
+ IF (ABS(ESUM).GT.0.D0) THEN
+ FAC = PHEP(4,II)/ESUM
+ ELSE
+ FAC = 1.0D0
+ ENDIF
+**
+ IF(IREJL.EQ.0) THEN
+ CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
+ P1(4) = P1(4)+FAC*DELE
+ ELSE
+ DO 450 K=1,4
+ P1(K) = PHEP(K,II)-FAC*PTR(K)
+ 450 CONTINUE
+ ENDIF
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ 400 CONTINUE
+ K1B = IPOS+K1-K2
+ IF(JMOHEP(2,J2).GT.0) THEN
+ II = JMOHEP(2,J2)
+ FAC = PHEP(4,II)/ESUM
+ IF(IREJL.EQ.0) THEN
+ CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
+ P1(4) = P1(4)+FAC*DELE
+ ELSE
+ DO 475 K=1,4
+ P1(K) = PHEP(K,II)-FAC*PTR(K)
+ 475 CONTINUE
+ ENDIF
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ ENDIF
+ K2B = -IPOS
+ ELSE
+ K1B = J1
+ K2B = J2
+ ENDIF
+C register first string/collapsed to hadron
+ IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
+ IF(NCODE(I).NE.5) THEN
+ CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
+ & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
+C label string as collapsed to hadron/resonance
+ NCODE(I) = -99
+ IDHEP(J1) = 92
+ ELSE
+ CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
+ & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
+ IDHEP(J1) = 91
+ ENDIF
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = K1A
+ NPOS(3,I) = K2A
+ ELSE
+ CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
+ & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
+ & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
+ IF(IDHEP(J1).EQ.90) THEN
+ NPOS(1,IPHIST(1,J1)) = IPOS
+ NPOS(2,IPHIST(1,J1)) = K1A
+ NPOS(3,IPHIST(1,J1)) = K2A
+C label string as collapsed to resonance-string
+ IDHEP(J1) = 91
+ ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
+ IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
+ ENDIF
+ ENDIF
+C register second string/hadron/parton
+ CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
+ & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
+ & ICOLOR(2,J2),IPOS,1)
+ IF(IDHEP(J2).EQ.90) THEN
+ NPOS(1,IPHIST(1,J2))=IPOS
+ NPOS(2,IPHIST(1,J2))=K1B
+ NPOS(3,IPHIST(1,J2))=K2B
+C label string touched by momentum transfer
+ IDHEP(J2) = 91
+ ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
+ IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
+ ENDIF
+ ICCOR = ICCOR+1
+ ITOUCH = ITOUCH+1
+C consistency checks
+ IF(IDEB(42).GE.5) THEN
+ CALL PHO_CHECK(-1,IDEV)
+ IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
+ ENDIF
+C jump to next iteration
+ GOTO 50
+ ENDIF
+ 90 CONTINUE
+ 100 CONTINUE
+C debug output
+ IF(IDEB(42).GE.15) THEN
+ IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
+ WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
+ CALL PHO_PREVNT(1)
+ ENDIF
+ ENDIF
+ END
+
+*$ CREATE PHO_PARCOR.FOR
+*COPY PHO_PARCOR
+CDECK ID>, PHO_PARCOR
+ SUBROUTINE PHO_PARCOR(MODE,IREJ)
+C********************************************************************
+C
+C conversion of string partons (using JETSET masses)
+C
+C input: MODE >0 position index of corresponding string
+C -1 initialization
+C -2 output of statistics
+C
+C output: /POSTRG/
+C IREJ 1 combination of strings impossible
+C 0 successful combination
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DELM = 0.005D0,
+ & DEPS = 1.D-15,
+ & EPS = 1.D-5)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+ DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
+ & PL(4,100),XMP(100),XML(100)
+
+ DOUBLE PRECISION PYMASS
+
+ IREJ = 0
+ IMODE = MODE
+C
+ IF(IMODE.GT.0) THEN
+ ICH = 0
+ I1 = JMOHEP(1,IMODE)
+ I2 = ABS(JMOHEP(2,IMODE))
+C copy to local field
+ L = 0
+ DO 100 I=I1,I2
+ L = L+1
+ DO 200 K=1,4
+ PL(K,L) = PHEP(K,I)
+ 200 CONTINUE
+ XMP(L) = PHEP(5,I)
+
+ XML(L) = PYMASS(IDHEP(I))
+
+ 100 CONTINUE
+ IPAR = L
+ XMC = PHEP(5,IMODE)
+ IF(IDEB(82).GE.20) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
+ & KEVENT,IMODE,L
+ DO 150 I=1,L
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 150 CONTINUE
+ ENDIF
+C
+C two parton configurations
+C -----------------------------------------
+ IF(IPAR.EQ.2) THEN
+ XM1 = XML(1)
+ XM2 = XML(2)
+ IF((XM1+XM2).GE.XMC) THEN
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
+ & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
+ & IMODE,XM1,XM2,XMC
+ GOTO 990
+ ENDIF
+C conversion possible
+ CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
+ & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
+ & KEVENT,IMODE,XMC
+ GOTO 990
+ ENDIF
+ ICH = 1
+ DO 115 K=1,4
+ PL(K,1) = PP1(K)
+ PL(K,2) = PP2(K)
+ XMP(1) = XM1
+ XMP(2) = XM2
+ 115 CONTINUE
+C
+C multi parton configurations
+C ---------------------------------
+ ELSE
+C
+C random selection of string side to start with
+ IF(DT_RNDM(XMC).LT.0.5D0) THEN
+ K1 = 1
+ K2 = IPAR
+ KS = 1
+ ELSE
+ K1 = IPAR
+ K2 = 1
+ KS = -1
+ ENDIF
+ ITER = 0
+C
+ 300 CONTINUE
+ IF(ITER.LT.4) THEN
+ KK = K1
+ K1 = K2
+ K2 = KK
+ KS = -KS
+ ELSE
+ GOTO 990
+ ENDIF
+ ITER = ITER+1
+C select method
+ IF(ITER.GT.2) GOTO 230
+
+C conversion according to color flow method
+ IFAI = 0
+ DO 210 II=K1,K2-KS,KS
+ DO 215 IK=II+KS,K2,KS
+ XM1 = XML(II)
+ XM2 = XML(IK)
+* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
+* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
+ IF((ABS(XM1-XMP(II)).GT.DELM)
+ & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
+ CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
+ & KEVENT,IMODE,II,IK
+ IREJ = 0
+ ELSE
+ ICH = ICH+1
+ DO 220 KK=1,4
+ PL(KK,II) = PP1(KK)
+ PL(KK,IK) = PP2(KK)
+ 220 CONTINUE
+ XMP(II) = XM1
+ XMP(IK) = XM2
+ GOTO 219
+ ENDIF
+ ELSE
+ GOTO 219
+ ENDIF
+ 215 CONTINUE
+ IFAI = II
+ 219 CONTINUE
+ 210 CONTINUE
+ IF(IFAI.NE.0) GOTO 300
+ GOTO 950
+C
+ 230 CONTINUE
+C
+C conversion according to remainder method
+ DO 350 I=K1,K2,KS
+ XM1 = XML(I)
+ IF(ABS(XM1-XMP(I)).GT.DELM) THEN
+ ICH = ICH+1
+ IFAI = I
+C conversion necessary
+ DO 400 K=1,4
+ PB1(K) = PL(K,I)
+ PB2(K) = PHEP(K,IMODE)-PB1(K)
+ 400 CONTINUE
+ XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
+ IF(XM2.LT.0.D0) THEN
+ IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
+ & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
+ GOTO 300
+ ENDIF
+ XM2 = SQRT(XM2)
+ IF((XM1+XM2).GE.XMC) THEN
+ IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
+ & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
+ GOTO 300
+ ENDIF
+C conversion possible
+ CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
+ & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
+ & ITER,IMODE,I
+ GOTO 300
+ ENDIF
+C calculate Lorentz transformation
+ CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
+ & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
+ & ITER,IMODE,I
+ GOTO 300
+ ENDIF
+ IFAI = 0
+C transform remaining partons
+ DO 450 L=K1,K2,KS
+ IF(L.NE.I) THEN
+ CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
+ DO 500 K=1,4
+ PL(K,L) = PP2(K)
+ 500 CONTINUE
+ ELSE
+ DO 550 K=1,4
+ PL(K,L) = PP1(K)
+ 550 CONTINUE
+ ENDIF
+ 450 CONTINUE
+ XMP(I) = XM1
+ ENDIF
+ 350 CONTINUE
+ ENDIF
+
+C register transformed partons
+ 950 CONTINUE
+ IREJ = 0
+ IF(ICH.NE.0) THEN
+ IP1 = NHEP+1
+ L = 0
+ DO 700 I=I1,I2
+ L= L+1
+ CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
+ & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
+ & ICOLOR(2,I),IPOS,1)
+ 700 CONTINUE
+ IP2 = IPOS
+C register string
+ CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
+ & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
+ & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
+C update /POSTRG/
+ I = IPHIST(1,IMODE)
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = IP1
+ NPOS(3,I) = -IP2
+ ENDIF
+C debug output
+ IF(IDEB(82).GE.20) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
+ & KEVENT,IMODE,L
+ DO 850 I=1,L
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 850 CONTINUE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
+ ENDIF
+ RETURN
+C rejection
+ 990 CONTINUE
+ IREJ = 1
+ IF(IDEB(82).GE.3) THEN
+ WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
+ & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
+ & IFAI,IPAR,IMODE,XMC
+ IF(IDEB(82).GE.5) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
+ & KEVENT,IMODE,IPAR
+ DO 155 I=1,IPAR
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 155 CONTINUE
+ ENDIF
+ ENDIF
+ RETURN
+
+ ELSE IF(IMODE.EQ.-1) THEN
+C initialization
+ RETURN
+
+ ELSE IF(IMODE.EQ.-2) THEN
+C final output
+ RETURN
+ ENDIF
+ END
+
+*$ CREATE PHO_STRING.FOR
+*COPY PHO_STRING
+CDECK ID>, PHO_STRING
+ SUBROUTINE PHO_STRING(IMODE,IREJ)
+C********************************************************************
+C
+C calculation of string combinatorics, Lorentz boosts and
+C particle codes
+C
+C - splitting of gluons
+C - strings will be built up from pairs of partons
+C according to their color labels
+C with IDHEP(..) = -1
+C - there can be other particles between to string partons
+C (these will be unchanged by string construction)
+C - string mass fine correction
+C
+C input: IMODE 1 complete string processing
+C -1 initialization
+C -2 output of statistics
+C
+C output: /POSTRG/
+C IREJ 1 combination of strings impossible
+C 0 successful combination
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IREJ = 0
+ IF(IMODE.EQ.-1) THEN
+ CALL PHO_POMCOR(-1)
+ CALL PHO_MASCOR(-1)
+ CALL PHO_PARCOR(-1,IREJ)
+
+ RETURN
+ ELSE IF(IMODE.EQ.-2) THEN
+ CALL PHO_POMCOR(-2)
+ CALL PHO_MASCOR(-2)
+ CALL PHO_PARCOR(-2,IREJ)
+
+ RETURN
+ ENDIF
+
+C generate enhanced graphs
+ IF(IPOIX2.GT.0) THEN
+ 200 CONTINUE
+ I1 = MAX(1,IPOIX1)
+ I2 = IPOIX2
+ IF(ISWMDL(14).EQ.1) IPOIX1 = 0
+ KSPOMS = KSPOM-1
+ KSREGS = KSREG
+ KHPOMS = KHPOM
+ KHDIRS = KHDIR
+ IDDFS1 = IDIFR1
+ IDDFS2 = IDIFR2
+ IDDPOS = IDDPOM
+ DO 110 I=I1,I2
+ IPOIX3 = I
+ KSPOM = 0
+ KSREG = 0
+ KHPOM = 0
+ KHDIR = 0
+ IF(IPORES(I).EQ.8) THEN
+ KSPOM = 2
+ LSPOM = 2
+ LHPOM = 0
+ LSREG = 0
+ LHDIR = 0
+ IGEN = abs(IPHIST(2,IPOPOS(1,I)))
+ CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
+ & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSPOM = KSPOMS+LSPOM
+ KSREG = KSREGS+LSREG
+ KHPOM = KHPOMS+LHPOM
+ KHDIR = KHDIRS+LHDIR
+ ELSE IF(IPORES(I).EQ.4) THEN
+ ITEMP = ISWMDL(17)
+ ISWMDL(17) = 0
+ CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
+ ISWMDL(17) = ITEMP
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSDPO = KSDPO+1
+ KSPOM = KSPOMS+KSPOM
+ KSREG = KSREGS+KSREG
+ KHPOM = KHPOMS+KHPOM
+ KHDIR = KHDIRS+KHDIR
+ ELSE
+ IDIF1 = 1
+ IDIF2 = 1
+ IF(IPORES(I).EQ.5) THEN
+ IDIF2 = 0
+ KSTRG = KSTRG+1
+ ELSE IF(IPORES(I).EQ.6) THEN
+ IDIF1 = 0
+ KSTRG = KSTRG+1
+ ELSE
+ KSLOO = KSLOO+1
+ ENDIF
+ ITEMP = ISWMDL(16)
+ ISWMDL(16) = 0
+ SPROB = 1.D0
+ CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
+ & 0,MSOFT,MHARD,IREJ)
+ ISWMDL(16) = ITEMP
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSPOM = KSPOMS+KSPOM
+ KSREG = KSREGS+KSREG
+ KHPOM = KHPOMS+KHPOM
+ KHDIR = KHDIRS+KHDIR
+ ENDIF
+ IDIFR1 = IDDFS1
+ IDIFR2 = IDDFS2
+ IDDPOM = IDDPOS
+ 110 CONTINUE
+ IF(IPOIX2.GT.I2) THEN
+ IPOIX1 = I2+1
+ GOTO 200
+ ENDIF
+ ENDIF
+
+C optional: split gluons to q-qbar pairs
+ IF(ISWMDL(9).GT.0) THEN
+ NHEPO = NHEP
+ DO 30 I=3,NHEPO
+ IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
+ ICG1=ICOLOR(1,I)
+ ICG2=ICOLOR(2,I)
+ IQ1 = 0
+ IQ2 = 0
+ DO 40 K=3,NHEPO
+ IF(ICOLOR(1,K).EQ.-ICG1) THEN
+ IQ1 = K
+ IF(IQ1*IQ2.NE.0) GOTO 45
+ ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
+ IQ2 = K
+ IF(IQ1*IQ2.NE.0) GOTO 45
+ ENDIF
+ 40 CONTINUE
+ WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
+ & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
+ CALL PHO_ABORT
+ 45 CONTINUE
+ CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(19).GE.5) THEN
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_STRING: no gluon splitting possible'
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ 30 CONTINUE
+ ENDIF
+
+C construct strings and write entries sorted by strings
+
+ ISTR = ISTR+1
+ NHEPO = NHEP
+ DO 50 I=3,NHEPO
+
+ IF(ISTR.GT.MSTR) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
+ & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IF(ISTHEP(I).EQ.1) THEN
+C hadrons / resonances / clusters
+ NPOS(1,ISTR) = I
+ NPOS(2,ISTR) = 0
+ NPOS(3,ISTR) = 0
+ NPOS(4,ISTR) = abs(IPHIST(2,I))
+ NCODE(ISTR) = -99
+ IPHIST(1,I) = ISTR
+ ISTR = ISTR+1
+ ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
+C quark /diquark terminated strings
+ ICOL1 = -ICOLOR(1,I)
+ P1 = PHEP(1,I)
+ P2 = PHEP(2,I)
+ P3 = PHEP(3,I)
+ P4 = PHEP(4,I)
+ ICH1 = IPHO_CHR3(I,2)
+ IBA1 = IPHO_BAR3(I,2)
+ CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
+ & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
+ & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
+ JM1 = IPOS
+
+ NRPOM = 0
+ 65 CONTINUE
+ DO 55 K=3,NHEPO
+ IF(ISTHEP(K).EQ.-1)THEN
+ IF(IDHEP(K).EQ.21) THEN
+ IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(2,K)
+ GOTO 60
+ ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(1,K)
+ GOTO 60
+ ENDIF
+ ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = 0
+ GOTO 60
+ ENDIF
+ ENDIF
+ 55 CONTINUE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
+ CALL PHO_ABORT
+ 60 CONTINUE
+ P1 = P1+PHEP(1,K)
+ P2 = P2+PHEP(2,K)
+ P3 = P3+PHEP(3,K)
+ P4 = P4+PHEP(4,K)
+ NRPOM = MAX(NRPOM,IPHIST(1,K))
+ ICH1 = ICH1+IPHO_CHR3(K,2)
+ IBA1 = IBA1+IPHO_BAR3(K,2)
+ CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
+ & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
+C further parton involved?
+ IF(ICOL1.NE.0) GOTO 65
+ JM2 = IPOS
+C register string
+ IGEN = IPHIST(2,K)
+ CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
+ & ISTR,IGEN,ICH1,IBA1,IPOS,1)
+C store additional string information
+ NPOS(1,ISTR) = IPOS
+ NPOS(2,ISTR) = JM1
+ NPOS(3,ISTR) = -JM2
+ NPOS(4,ISTR) = abs(IPHIST(2,K))
+C calculate CPC string codes
+ CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
+ & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
+ ISTR = ISTR+1
+ ENDIF
+ 50 CONTINUE
+
+ DO 150 I=3,NHEPO
+
+ IF(ISTR.GT.MSTR) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
+ & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IF(ISTHEP(I).EQ.-1) THEN
+C gluon loop-strings
+ ICOL1 = -ICOLOR(1,I)
+ P1 = PHEP(1,I)
+ P2 = PHEP(2,I)
+ P3 = PHEP(3,I)
+ P4 = PHEP(4,I)
+ IBA1 = 0
+ ICH1 = 0
+ CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
+ & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
+ & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
+ JM1 = IPOS
+C
+ NRPOM = 0
+ 165 CONTINUE
+ IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
+ DO 155 K=I,NHEPO
+ IF(ISTHEP(K).EQ.-1)THEN
+ IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(2,K)
+ GOTO 160
+ ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(1,K)
+ GOTO 160
+ ENDIF
+ ENDIF
+ 155 CONTINUE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
+ CALL PHO_ABORT
+ 160 CONTINUE
+ P1 = P1+PHEP(1,K)
+ P2 = P2+PHEP(2,K)
+ P3 = P3+PHEP(3,K)
+ P4 = P4+PHEP(4,K)
+ NRPOM = MAX(NRPOM,IPHIST(1,K))
+ CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
+ & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
+C further parton involved?
+ IF(ICOL1.NE.0) GOTO 165
+ 170 CONTINUE
+ JM2 = IPOS
+C register string
+ IGEN = IPHIST(2,K)
+ CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
+ & ISTR,IGEN,ICH1,IBA1,IPOS,1)
+C store additional string information
+ NPOS(1,ISTR) = IPOS
+ NPOS(2,ISTR) = JM1
+ NPOS(3,ISTR) = -JM2
+ NPOS(4,ISTR) = abs(IPHIST(2,K))
+C calculate CPC string codes
+ CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
+ & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
+ ISTR = ISTR+1
+ ENDIF
+ 150 CONTINUE
+
+ ISTR = ISTR-1
+
+ IF(IDEB(19).GE.17) THEN
+ WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+C pomeron corrections
+ CALL PHO_POMCOR(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(38) = IFAIL(38)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C string mass corrections
+ CALL PHO_MASCOR(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(34) = IFAIL(34)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C parton mass corrections
+ DO 100 I=1,ISTR
+ IF(NCODE(I).GE.0) THEN
+ CALL PHO_PARCOR(NPOS(1,I),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(35) = IFAIL(35)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+
+C statistics of hard processes
+ DO 550 I=3,NHEP
+ IF(ISTHEP(I).EQ.25) THEN
+ K = IMPART(I)
+ II = IDHEP(I)
+ MH_acc_2(K,II) = MH_acc_2(K,II)+1
+ ENDIF
+ 550 CONTINUE
+
+C debug: write out strings
+ IF(IDEB(19).GE.5) THEN
+ IF(IDEB(19).GE.10)
+ & CALL PHO_CHECK(1,IDEV)
+ IF(IDEB(19).GE.15) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PRSTRG
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_STRFRA.FOR
+*COPY PHO_STRFRA
+CDECK ID>, PHO_STRFRA
+ SUBROUTINE PHO_STRFRA(IREJ)
+C********************************************************************
+C
+C do all fragmentation of strings
+C
+C output: IREJ 0 successful
+C 1 rejection
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+ INTEGER IREJ
+
+ DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
+
+ INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
+ & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
+
+ integer indx(500),indx_max
+
+ DOUBLE PRECISION DT_RNDM
+ INTEGER ipho_pdg2id
+ EXTERNAL DT_RNDM,ipho_pdg2id
+
+ DOUBLE PRECISION PYP,RQLUN
+ INTEGER PYK
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+
+ DIMENSION IJOIN(100)
+
+ IREJ = 0
+ IF(ABS(ISWMDL(6)).GT.3) THEN
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
+ & 'invalid value of ISWMDL(6)',ISWMDL(6)
+ CALL PHO_ABORT
+ ENDIF
+
+C popcorn suppression
+ IF(PARMDL(134).GT.0.D0) THEN
+ IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
+ MSTJ(12) = 2
+ ELSE
+ MSTJ(12) = 1
+ ENDIF
+ ENDIF
+
+C copy partons to fragmentation code JETSET
+ IP = 0
+ IP_old = 1
+
+ DO 300 J=1,ISTR
+
+C select partons with common production process
+ IGEN = NPOS(4,J)
+ if(IGEN.lt.0) goto 299
+
+ indx_max = 0
+ DO 400 I=J,ISTR
+ if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
+
+C write final particles/resonances to JETSET
+ IF(NCODE(I).EQ.-99) THEN
+ II = NPOS(1,I)
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+
+ if(indx_max.eq.500) then
+ WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
+ & 'no space left in index vector (indx,Kevent)',
+ & indx_max,KEVENT
+ IREJ = 1
+ return
+ endif
+
+ indx_max = indx_max+1
+ indx(indx_max) = II
+C write partons to JETSET
+ ELSE IF(NCODE(I).GE.0) THEN
+ K1 = JMOHEP(1,NPOS(1,I))
+ K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
+ IJ = 0
+ DO II=K1,K2
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+ IJ = IJ+1
+ IJOIN(IJ) = IP
+ indx_max = indx_max+1
+ indx(indx_max) = II
+
+ ENDDO
+ II = JMOHEP(2,NPOS(1,I))
+ IF((II.GT.0).AND.(II.NE.K1)) THEN
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+ IJ = IJ+1
+ IJOIN(IJ) = IP
+ indx_max = indx_max+1
+ indx(indx_max) = II
+
+ ENDIF
+ N = IP
+C connect partons to strings
+
+ CALL PYJOIN(IJ,IJOIN)
+
+ ENDIF
+
+ NPOS(4,I) = -NPOS(4,I)
+ endif
+ 400 continue
+
+C set Lund counter
+ N = IP
+ if(IP.eq.0) goto 299
+
+C hard final state evolution
+ IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
+ ISH = 0
+ do 125 k1=1,indx_max
+ I = indx(k1)
+ IF(IPHIST(1,I).LE.-100) THEN
+ ISH = ISH+1
+ IJOIN(ISH) = I
+ ENDIF
+ 125 continue
+ IF(ISH.GE.2) THEN
+ DO 130 K1=1,ISH
+ IF(IJOIN(K1).EQ.0) GOTO 130
+ I = IJOIN(K1)
+ IF((IPAMDL(102).EQ.1)
+ & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
+ DO 135 K2=K1+1,ISH
+ IF(IJOIN(K2).EQ.0) GOTO 135
+ II = IJOIN(K2)
+ IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
+ PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
+ PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
+ RQLUN = MIN(PT1,PT2)
+
+ IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
+ & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
+ CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
+
+ IJOIN(K1) = 0
+ IJOIN(K2) = 0
+ GOTO 130
+ ENDIF
+ 135 CONTINUE
+ 130 CONTINUE
+ ENDIF
+ ENDIF
+
+C fragment parton / hadron configuration (hadronization & decay)
+
+ IF(ISWMDL(6).NE.0) THEN
+ II = MSTU(21)
+ MSTU(21) = 1
+
+ CALL PYEXEC
+
+ MSTU(21) = II
+C Lund warning?
+ if(MSTU(28).ne.0) then
+ IF(IDEB(22).GE.10) THEN
+ WRITE(LO,'(1X,A,I12,I3)')
+ & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
+ & KEVENT,MSTU(28)
+ CALL PHO_PREVNT(2)
+ ENDIF
+ endif
+C event accepted?
+ IF(MSTU(24).NE.0) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(1X,A,I12,I3)')
+ & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
+ & KEVENT,MSTU(24)
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ IP = N
+C change particle status in JETSET to avoid internal adjustments
+ do k1=IP_old,IP
+ K(k1,1) = K(k1,1)+1000
+ enddo
+ IP_old = IP+1
+
+ 299 continue
+ 300 CONTINUE
+
+C restore original JETSET particle status codes
+ do i=1,N
+ K(i,1) = K(i,1)-1000
+ enddo
+
+* IF(IDEB(22).GE.25) THEN
+* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
+* & 'particle/string system before fragmentation'
+* CALL PHO_PREVNT(2)
+* ENDIF
+
+C copy hadrons back to POEVT1 / POEVT2
+
+ IF(IP.GT.0) THEN
+ NHEP1 = NHEP+1
+
+ NLINES = PYK(0,1)
+
+C copy hadrons back with full history information
+ IF(IPAMDL(178).EQ.1) THEN
+ DO 155 II=1,ISTR
+ IF(NCODE(II).GE.0) THEN
+ K1 = IPHIST(2,NPOS(2,II))
+ K2 = IPHIST(2,-NPOS(3,II))
+ ELSE IF(NCODE(II).EQ.-99) THEN
+ K1 = IPHIST(2,NPOS(1,II))
+ K2 = K1
+ ELSE
+ GOTO 149
+ ENDIF
+ IFOUND = 0
+ DO 160 J=1,NLINES
+
+ IF(PYK(J,7).EQ.1) THEN
+ IPMOTH = PYK(J,15)
+
+ IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
+
+ IBAM = ipho_pdg2id(PYK(J,8))
+
+ IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
+ & 'LUND interface (1) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ IFOUND = IFOUND+1
+
+ PX = PYP(J,1)
+ PY = PYP(J,2)
+ PZ = PYP(J,3)
+ HE = PYP(J,4)
+ XMB = PYP(J,5)**2
+
+C register parton/hadron
+ IS = 1
+ IF(IBAM.EQ.0) THEN
+ IF(ISWMDL(6).EQ.0) THEN
+ IS = -1
+ ELSE
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
+ & 'LUND interface (2) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
+ & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
+
+ ISTHEP(IPOS) = 1
+ ENDIF
+ ENDIF
+ 160 CONTINUE
+ IF(IFOUND.EQ.0) THEN
+ IF(IDEB(2).GE.2) THEN
+ WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
+ & 'no particles found for string (EVE,ISTR):',KEVENT,II
+ ENDIF
+ ISTHEP(NPOS(1,II)) = 2
+ ENDIF
+ 149 CONTINUE
+ 155 CONTINUE
+ ELSE
+C copy hadrons back without history information
+ JDAHEP(1,1) = NHEP1
+ JDAHEP(1,2) = NHEP1
+ DO 170 J=1,NLINES
+
+ IF(PYK(J,7).EQ.1) THEN
+ IBAM = ipho_pdg2id(PYK(J,8))
+
+ IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_STRFRA: LUND interface (3) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ PX = PYP(J,1)
+ PY = PYP(J,2)
+ PZ = PYP(J,3)
+ HE = PYP(J,4)
+ XMB = PYP(J,5)**2
+
+C register parton/hadron
+ IS = 1
+ IF(IBAM.EQ.0) THEN
+ IF(ISWMDL(6).EQ.0) THEN
+ IS = -1
+ ELSE
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_STRFRA: LUND interface (4) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
+ & HE,J,0,0,0,IPOS,1)
+
+ ISTHEP(IPOS) = 1
+ ENDIF
+ 170 CONTINUE
+ DO 180 II=1,ISTR
+ IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
+ & ISTHEP(NPOS(1,II)) = 2
+ 180 CONTINUE
+ ENDIF
+ ENDIF
+
+C debug event status
+ IF(IDEB(22).GE.15) THEN
+ WRITE(LO,'(//1X,A)')
+ & 'PHO_STRFRA: particle system after fragmentation'
+ CALL PHO_PREVNT(2)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_EVEINI.FOR
+*COPY PHO_EVEINI
+CDECK ID>, PHO_EVEINI
+ SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
+C********************************************************************
+C
+C prepare /POEVT1/ for new event
+C
+C first subroutine called for each event
+C
+C input: P1(4) particle 1
+C P2(4) particle 2
+C IMODE 0 general initialization
+C 1 initialization of particles and kinematics
+C 2 initialization after internal rejection
+C
+C output: IP1,IP2 index of interacting particles
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4)
+
+ PARAMETER ( EPS = 1.D-5,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION IM(2)
+
+C reset debug variables
+ KSPOM = 0
+ KHPOM = 0
+ KSREG = 0
+ KHDIR = 0
+ KSTRG = 0
+ KHTRG = 0
+ KSLOO = 0
+ KHLOO = 0
+ KSDPO = 0
+ KSOFT = 0
+ KHARD = 0
+C
+ IDNODF = 0
+ IDIFR1 = 0
+ IDIFR2 = 0
+ IDDPOM = 0
+ ISTR = 0
+ IPOIX1 = 0
+ IF(ISWMDL(14).GT.0) IPOIX1 = 1
+ IPOIX2 = 0
+ IPOIX3 = 0
+C reset /POEVT1/ and /POEVT2/
+ CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
+ & 0,0,0,0,IPOS,0)
+ CALL PHO_SELCOL(0,0,0,0,0,0,0)
+ DO 15 I=0,10
+ IPOWGC(I) = 0
+ 15 CONTINUE
+
+C initialization of particle kinematics
+
+C lepton-photon/hadron-photon vertex and initial particles
+ IM(1) = 0
+ IM(2) = 0
+ IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
+ & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
+ ELSE
+ CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
+ & P1(4),0,0,0,0,IP1,1)
+ ENDIF
+ IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
+ & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
+ ELSE
+ CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
+ & P2(4),0,0,0,0,IP2,1)
+ ENDIF
+ IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
+ & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
+ CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
+ & P1(4),0,0,0,0,IP1,1)
+ ENDIF
+ IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
+ & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
+ CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
+ & P2(4),0,0,0,0,IP2,1)
+ ENDIF
+ NEVHEP = KACCEP
+
+ IF(IMODE.LE.1) THEN
+C CMS energy
+ ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
+ & -(P1(3)+P2(3))**2)
+* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
+ PMASS(1) = PHEP(5,IP1)
+ PVIRT(1) = 0.D0
+ IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
+ PMASS(2) = PHEP(5,IP2)
+ PVIRT(2) = 0.D0
+ IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
+ ENDIF
+
+C cross section calculations
+
+ IF(IMODE.NE.1) THEN
+ IP = 1
+ CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
+ & ECM,PVIRT(1),PVIRT(2))
+ ENDIF
+
+ IF(IMODE.LE.0) THEN
+C effective cross section
+ SIGGEN(3) = 0.D0
+ IF(ISWMDL(2).ge.1) THEN
+ IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
+ & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
+ & -SIGHDD-SIGDIR
+ IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
+ IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
+ IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
+ IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
+ IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
+ IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
+ IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
+C simulate only hard scatterings
+ ELSE
+ IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
+ IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
+ ENDIF
+
+ ENDIF
+
+C reset of mother/daughter relations only (IMODE = 2)
+
+C debug output
+ IF(IDEB(63).GE.15) THEN
+ WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
+ & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
+ IF(IMODE.LE.0) THEN
+ WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
+ & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
+ & FSUP,FSUH,FSUD
+ ONEM = -1.D0
+ ITMP = IDEB(57)
+ IDEB(57) = MAX(5,ITMP)
+ CALL PHO_XSECT(1,0,ONEM)
+ IDEB(57) = ITMP
+ ENDIF
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_CSINT.FOR
+*COPY PHO_CSINT
+CDECK ID>, PHO_CSINT
+ SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
+C********************************************************************
+C
+C calculate cross sections by interpolation
+C
+C input: IP particle combination
+C IFPA/B particle PDG number
+C IHLA/B particle helicity (photons only)
+C ECM c.m. energy (GeV)
+C PVIR2A virtuality of particle A (GeV**2, positive)
+C PVIR2B virtuality of particle B (GeV**2, positive)
+C
+C output: cross sections stored in /POCSEC/
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-5,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+ DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
+
+ dimension PD(-6:6),FH_T(2),FH_L(2)
+
+C debug
+ IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
+ & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
+ & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
+
+C check currently stored cross sections
+ IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
+ & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
+ & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
+C nothing to calculate
+ IF(IDEB(15).GE.20)
+ & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
+ RETURN
+ ELSE
+
+C copy to local fields
+ IFPAP(1) = IFPA
+ IFPAP(2) = IFPB
+ IHEL(1) = IHLA
+ IHEL(2) = IHLB
+ PVIRT(1) = PVIR2A
+ PVIRT(2) = PVIR2B
+
+C load cross sections from interpolation table
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 2
+ ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = ISIMAX-1
+ I2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1=1.D0-FAC2
+
+C cross section dependence on photon virtualities
+ DO 140 K=1,2
+ FSUP(K) = 1.D0
+ FSUD(K) = 1.D0
+ FSUH(K) = 1.D0
+ IF(IFPAP(K).EQ.22) THEN
+ IF(ISWMDL(10).GE.1) THEN
+ FSUP(K) = 0.D0
+ FSUT(K) = 0.D0
+ FSUL(K) = 0.D0
+ FSUH(K) = 0.D0
+C GVDM factors for transverse/longitudinal photons
+ DO 150 I=1,3
+ FSUT(K) = FSUT(K)+PARMDL(26+I)
+ & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
+ FSUL(K) = FSUL(K)
+ & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
+ & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
+ 150 CONTINUE
+ FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
+C transverse part
+ IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
+ FSUP(K) = FSUT(K)
+ FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
+C diffraction of trans. photons corresponds mainly to leading twist
+ FSUD(K) = 1.D0
+ ENDIF
+C longitudinal (scalar) part
+ IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
+ FSUP(K) = FSUP(K)+FSUL(K)
+ FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
+C diffraction of long. photons corresponds mainly to higher twist
+ FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
+ & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
+ & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
+ ENDIF
+C debug output
+ if(ideb(15).ge.10) then
+ WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
+ & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
+ & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
+ endif
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+
+ FACP = FSUP(1)*FSUP(2)
+ FACH = FSUH(1)*FSUH(2)
+ FACD = FSUD(1)*FSUD(2)
+
+C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
+
+ if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
+ & .and.(IPAMDL(117).gt.0)) then
+C check kinematic limit
+ Q2_max = max(PVIRT(1),PVIRT(2))
+ Q2_min = min(PVIRT(1),PVIRT(2))
+ if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
+
+C calculate F2 from current parton density
+ if(PVIRT(1).gt.PVIRT(2)) then
+ K = 2
+ else
+ K = 1
+ endif
+ Q2 = Q2_max
+ P2 = Q2_min
+ X = Q2/(ECM**2+Q2+P2)
+ call pho_actpdf(IFPAP(K),K)
+ call pho_pdf(K,X,Q2,P2,PD)
+C light quark contribution
+ F2_light = 0.D0
+ do j=1,3
+ F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
+ enddo
+C heavy quark contribution
+ call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
+ F2_c = 2.D0*4.D0/9.D0*xpdf_c
+ F2 = (F2_light+F2_c)
+
+C calculate model prediction
+ SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
+ SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+
+ if(ISWMDL(10).ge.2) then
+
+C calculate all helicity combinations
+ if(IPAMDL(115).eq.0) then
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
+C photon helicity factors
+ FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
+ FH_L(1) = 1.D0-FH_T(1)
+ FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
+ FH_L(2) = 1.D0-FH_T(2)
+ SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
+ & + SIGDIH*FH_T(1)*FH_T(2)
+ & + SIGSRH(1)*FH_T(1)*FSUT(2)
+ & + SIGSRH(2)*FSUT(1)*FH_T(2)
+ SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
+ & + SIGDIH*FH_T(1)*FH_L(2)
+ & + SIGSRH(1)*FH_T(1)*FSUL(2)
+ & + SIGSRH(2)*FSUT(1)*FH_L(2)
+ SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
+ & + SIGDIH*FH_L(1)*FH_T(2)
+ & + SIGSRH(1)*FH_L(1)*FSUT(2)
+ & + SIGSRH(2)*FSUL(1)*FH_T(2)
+ SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
+ & + SIGDIH*FH_L(1)*FH_L(2)
+ & + SIGSRH(1)*FH_L(1)*FSUL(2)
+ & + SIGSRH(2)*FSUL(1)*FH_L(2)
+ else
+C use explicit PDF virtuality dependence (pre-tabulated)
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
+ write(LO,*) ' PHO_CSINT: invalid option for F2 matching'
+ stop
+* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
+* & Max_pro_2,3,4,1)
+* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
+* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
+* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
+* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
+* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
+* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
+* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
+* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
+ endif
+ Xnu = Ecm*Ecm+Q2+P2
+ F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
+ & *137.D0/GeV2mb
+ if(K.eq.2) then
+ F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
+ F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
+ & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
+ else
+ F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
+ F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
+ & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
+ endif
+
+ else
+
+C assume sig_eff = sigtot
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
+ SIGeff = SIGtmp*FSUP(1)*FSUP(2)
+ & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
+ Xnu = Ecm*Ecm+Q2+P2
+ F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
+ & *137.D0/GeV2mb
+ F2m = F2_fac*SIGeff
+ F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
+ endif
+* write(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
+* write(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
+
+C global factor to re-scale suppression of soft contributions
+ Fcorr = (F2-F2m+F2s)/F2s
+* write(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
+ FACP = FACP*Fcorr
+
+ endif
+ endif
+
+ SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
+ SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
+ SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
+ J = 2
+ DO 5 I=0,4
+ DO 6 K=0,4
+ J = J+1
+ SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
+ & *FACP**2
+ 6 CONTINUE
+ 5 CONTINUE
+
+ SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+ SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
+C suppression of multi-pomeron graphs (diffraction)
+ SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
+ & *FACP**2*FACD
+ SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
+ SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
+ & *FACP**2
+ SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
+ SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
+ & *FACP**2
+ SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
+ & *FACP**2
+ SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
+ & *FACP**2
+ SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
+ & *FACP**2
+
+C corrections due to photon virtuality dependence of PDFs
+ if(iswmdl(2).eq.1) then
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+C minimum bias event generation
+ IF(IPAMDL(115).GE.1) THEN
+C all the virtuality dependence is given by PDF parametrization
+ SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
+ IF(IPAMDL(116).GE.2) THEN
+C direct interaction according to full QPM calculation
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ ELSE
+C direct interaction suppressed according to helicity factor
+ SIGDIH = HSig(14)*FACH
+ SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
+ SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
+ ENDIF
+ write(LO,*) ' PHO_CSINT: option not supported yet'
+ stop
+ ELSE
+C rescale relevant hard processes
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
+ SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
+ & +SIGSRH(2)*FSUP(1)*FSUH(2)
+ SIGINE = SIGtmp+SIGDIR
+ SIGTOT = SIGINE+SIGELA
+ ENDIF
+ else
+C only hard interactions
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+ SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
+ SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
+ SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
+ SIGHAR = HSig(9)*FACH
+ endif
+
+ SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
+ SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
+ SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
+ J = 39
+ DO 9 I=1,4
+ DO 10 K=1,4
+ J = J+1
+ SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
+ 10 CONTINUE
+ 9 CONTINUE
+ SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
+ SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
+
+ IPFIL = IP
+ IFAFIL = IFPA
+ IFBFIL = IFPB
+ ECMFIL = ECM
+ P2AFIL = PVIR2A
+ P2BFIL = PVIR2B
+
+ IF(IDEB(15).GE.20)
+ & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PRIMKT.FOR
+*COPY PHO_PRIMKT
+CDECK ID>, PHO_PRIMKT
+ SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
+C***********************************************************************
+C
+C give primordial kt to partons entering hard scatterings and
+C remants connected to hard parton-parton interactions by color flow
+C
+C input: IMODE -2 output of statistics
+C -1 initialization
+C 1 sampling of primordial kt
+C IF first entry in /POEVT1/ to check
+C IL last entry in /POEVT1/ to check
+C PTCUT current value of PTCUT to distinguish
+C between soft and hard
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION DEPS
+ PARAMETER ( DEPS = 1.D-15 )
+
+ INTEGER IMODE,IF,IL,IREJ
+ DOUBLE PRECISION PTCUT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
+ DIMENSION PTS(0:2,5),XP(5),
+ & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
+
+ INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
+
+ PARAMETER (IRMAX=200)
+ DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
+
+ DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
+ & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
+ INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
+
+C debug output
+ IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+
+C give primordial kt to partons engaged in a hard scattering
+
+ IF(IMODE.EQ.1) THEN
+
+ ISTART = IF
+
+ 100 CONTINUE
+
+ NHD = 0
+ IBAL(1) = 0
+ IBAL(2) = 0
+ IROT = 0
+ ICOM = 0
+ DO 110 I=ISTART,IL
+ IF(ISTHEP(I).EQ.25) THEN
+C hard scattering number
+ NHD = IPHIST(1,I+1)
+ ICOM = I
+ K = LSIDX(NHD/100)
+C calculate momenta of incoming partons
+ POLD(1,1) = XHD(K,1)*ECMP/2.D0
+ POLD(2,1) = POLD(1,1)
+ POLD(1,2) = -XHD(K,2)*ECMP/2.D0
+ POLD(2,2) = -POLD(1,2)
+ ISTART = I+3
+ GOTO 150
+ ENDIF
+ 110 CONTINUE
+ RETURN
+
+ 150 CONTINUE
+
+C search for partons involved in hard interaction
+ INEXT = 0
+ IROT = 0
+ DO 500 I=ISTART,IL
+ IF(ABS(ISTHEP(I)).EQ.1) THEN
+C hard scatterd partons (including ISR)
+ IF((IPHIST(1,I).EQ.-NHD)
+ & .OR.(IPHIST(1,I).EQ.NHD+1)
+ & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
+ IROT = IROT+1
+
+ IF(IROT.GT.IRMAX) THEN
+ WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'no memory left in IROTT, event rejected (max/IROT)',
+ & IRMAX,IROT
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IROTT(IROT) = I
+C hard remnant
+ ELSE IF(IPHIST(1,I).EQ.NHD) THEN
+ IF(PHEP(3,I).GT.0.D0) THEN
+ J = 1
+ ELSE
+ J = 2
+ ENDIF
+ IBAL(J) = IBAL(J)+1
+ IBALT(IBAL(J),J) = I
+ XP2(IBAL(J),J) = PHEP(3,I)/ECMP
+ IF(ISWMDL(24).EQ.0) THEN
+ IV2(IBAL(J),J) = 0
+ IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
+ ELSE IF(ISWMDL(24).EQ.1) THEN
+ IV2(IBAL(J),J) = -1
+ ELSE
+ IV2(IBAL(J),J) = 1
+ ENDIF
+ ENDIF
+C possibly further hard scattering
+ ELSE IF(ISTHEP(I).EQ.25) THEN
+ INEXT = 1
+ ISTART = I
+ GOTO 550
+ ENDIF
+ 500 CONTINUE
+ 550 CONTINUE
+
+C debug output
+ if(IDEB(10).ge.15) then
+ WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
+ & 'hard scattering number: ',NHD/100
+ WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
+ & 'number of entries to rotate: ',IROT
+ DO I=1,IROT
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'entries to rotate: ',I,IROTT(I)
+ ENDDO
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'number of entries to balance: ',IBAL
+ DO J=1,2
+ DO I=1,IBAL(J)
+ WRITE(LO,'(1X,2A,I2,2I5)')
+ & 'PHO_PRIMKT: entries to balance (side,no,line)',
+ & J,I,IBALT(I,J)
+ ENDDO
+ ENDDO
+ endif
+
+C incoming partons (comment lines), skip direct interacting particles
+ DO 120 K=1,2
+ IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
+ IF(PHEP(3,ICOM+K).GT.0.D0) THEN
+ J = 1
+ ELSE
+ J = 2
+ ENDIF
+ IBAL(J) = IBAL(J)+1
+ IBALT(IBAL(J),J) = -ICOM-K
+ XP2(IBAL(J),J) = POLD(1,J)/ECMP
+ IV2(IBAL(J),J) = -1
+ ENDIF
+ 120 CONTINUE
+
+C check consistency
+ IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
+ WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
+ & 'inconsistent hard scattering remnant for event: ',KEVENT
+ WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+ WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
+ DO 390 I=1,IROT
+ WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
+ 390 CONTINUE
+ DO 392 J=1,2
+ DO 395 I=1,IBAL(J)
+ WRITE(LO,'(1X,A,I2,2I5)')
+ & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
+ 395 CONTINUE
+ 392 CONTINUE
+ IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
+ ENDIF
+
+C calculate primordial kt
+
+C something to do?
+ IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
+
+C add transverse momentum (overwrite /POEVT1/ entries)
+ DO 200 J=1,2
+ IF(IBAL(J).GT.1) THEN
+C sample from truncated distribution
+ K = IBAL(J)
+ DO 180 I=1,K
+ IV(I) = IV2(I,J)
+ XP(I) = XP2(I,J)
+ 180 CONTINUE
+ 190 CONTINUE
+ CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
+ IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
+C transform incoming partons of hard scattering
+ DEL = ABS(POLD(1,J))+POLD(2,J)
+ PT2 = PTS(0,K)**2
+ DEL2 = DEL*DEL
+ PNEW(1,J) = PTS(1,K)
+ PNEW(2,J) = PTS(2,K)
+ PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
+ PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
+C spectator partons
+ ESUM = 0.D0
+ DO 220 I=1,IBAL(J)-1
+ K = IBALT(I,J)
+ PHEP(1,K) = PHEP(1,K)+PTS(1,I)
+ PHEP(2,K) = PHEP(2,K)+PTS(2,I)
+ ESUM = ESUM+PHEP(4,K)
+ 220 CONTINUE
+C long. momentum transfer
+ PP(3) = PNEW(3,J) - POLD(1,J)
+ PP(4) = PNEW(4,J) - POLD(2,J)
+ DO 230 I=1,IBAL(J)-1
+ K = IBALT(I,J)
+ FAC = PHEP(4,K)/ESUM
+ PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
+ PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
+ 230 CONTINUE
+
+C debug output
+ IF(IDEB(10).GE.15) THEN
+ WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
+ & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
+ WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
+ & 'new incoming:',J,(PNEW(I,J),I=1,4)
+ ENDIF
+
+ ELSE
+ PNEW(1,J) = 0.D0
+ PNEW(2,J) = 0.D0
+ PNEW(3,J) = POLD(1,J)
+ PNEW(4,J) = POLD(2,J)
+ ENDIF
+ 200 CONTINUE
+
+C transformation of hard scattering final states (including ISR)
+
+C old parton c.m. energy
+ SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
+ EI = SQRT(SI)
+C new parton c.m. energy
+ SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
+ & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
+ EF = SQRT(SF)
+ FAC = EF/EI
+C debug output
+ IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
+ & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
+
+C calculate Lorentz transformation
+ GAZ = -(POLD(1,1)+POLD(1,2))/EI
+ GAE = (POLD(2,1)+POLD(2,2))/EI
+ DO 240 I=1,4
+ GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
+ 240 CONTINUE
+ CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
+ & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
+ PTOT = MAX(DEPS,PTOT)
+ COD= PP(3)/PTOT
+ SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
+ COF= 1.D0
+ SIF= 0.D0
+ IF(PTOT*SID.GT.1.D-5) THEN
+ COF=PP(1)/(SID*PTOT)
+ SIF=PP(2)/(SID*PTOT)
+ ANORF=SQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+
+C debug output
+C check consistency initial/final configuration before rotation
+ IF(IDEB(10).GE.25) THEN
+ WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
+ & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
+ DO I=1,4
+ PP(I) = 0.D0
+ ENDDO
+ DO I=1,IROT
+ K = IROTT(I)
+ DO J=1,4
+ PP(J) = PP(J)+PHEP(J,K)
+ ENDDO
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: fin. momentum (1):',PP
+ ENDIF
+
+C apply rotation/boost to scattered particles
+ DO 400 I=1,IROT
+ K = IROTT(I)
+ DO 350 J=1,4
+ PP(J) = FAC*PHEP(J,K)
+ 350 CONTINUE
+ CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
+ & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
+ CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
+ & COD,SID,COF,SIF,XX,YY,ZZ)
+ EE = PHEP(4,K)
+ CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
+ 400 CONTINUE
+
+C debug output
+C check consistency initial/final configuration after rotation
+ IF(IDEB(10).GE.25) THEN
+ DO I=1,4
+ PP(I) = PNEW(I,1)+PNEW(I,2)
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: ini. momentum (2):',PP
+ DO I=1,4
+ PP(I) = 0.D0
+ ENDDO
+ DO I=1,IROT
+ K = IROTT(I)
+ DO J=1,4
+ PP(J) = PP(J)+PHEP(J,K)
+ ENDDO
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: fin. momentum (2):',PP
+ ENDIF
+
+ ENDIF
+
+ IF(INEXT.EQ.1) GOTO 100
+
+C initialization
+
+ ELSE IF(IMODE.EQ.-1) THEN
+
+C output of statistics etc.
+
+ ELSE IF(IMODE.EQ.-2) THEN
+
+C something wrong
+
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PARTPT.FOR
+*COPY PHO_PARTPT
+CDECK ID>, PHO_PARTPT
+ SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
+C********************************************************************
+C
+C assign to soft partons
+C
+C input: IMODE -2 output of statistics
+C -1 initialization
+C 0 sampling of pt for soft partons belonging to
+C soft Pomerons
+C 1 sampling of pt for soft partons belonging to
+C hard Pomerons
+C IF first entry in /POEVT1/ to check
+C IL last entry in /POEVT1/ to check
+C PTCUT current value of PTCUT to distinguish
+C between soft and hard
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C (soft pt is sampled by call to PHO_SOFTPT)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15 )
+
+ INTEGER IMODE,IF,IL,IREJ
+ DOUBLE PRECISION PTCUT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DOUBLE PRECISION PTS,PB,XP,XPB,PC
+ DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
+
+ INTEGER MODIFY,IV,IVB
+ DIMENSION MODIFY(50),IV(50),IVB(2)
+
+C debug output
+ IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+
+ IF(IMODE.LT.0) GOTO 1000
+
+ IREJ = 0
+ IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
+
+C count entries to modify
+ IENTRY = 0
+ PTCUT2 = PTCUT**2
+ EMIN = 1.D20
+ IPEAK = 1
+ ISTART = IF
+
+C soft Pomerons
+
+ IF(IMODE.EQ.0) THEN
+ DO 300 I=ISTART,IL
+ IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
+ IENTRY = IENTRY+1
+ MODIFY(IENTRY) = I
+ XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
+ IV(IENTRY) = 0
+ IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
+ IF(PHEP(4,I).LT.EMIN) THEN
+ EMIN = PHEP(4,I)
+ IPEAK = IENTRY
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+
+C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+ DO 350 I=ISTART,IL
+ IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
+ IF(MOD(IPHIST(1,I),100).EQ.0) THEN
+ IENTRY = IENTRY+1
+ MODIFY(IENTRY) = I
+ XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
+ IF(ISWMDL(24).EQ.0) THEN
+ IV(IENTRY) = 0
+ IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
+ ELSE IF(ISWMDL(24).EQ.1) THEN
+ IV(IENTRY) = -1
+ ELSE
+ IV(IENTRY) = 1
+ ENDIF
+ IF(PHEP(4,I).LT.EMIN) THEN
+ EMIN = PHEP(4,I)
+ IPEAK = IENTRY
+ ENDIF
+ ENDIF
+ ENDIF
+ 350 CONTINUE
+
+C something wrong
+
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C debug output
+ IF(IDEB(6).GE.5) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
+ & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
+ IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
+ ENDIF
+
+C nothing to do
+ IF(IENTRY.LE.1) RETURN
+
+C sample pt of soft partons
+
+ IF(ISWMDL(5).LE.1) THEN
+ ITER = 0
+ IPEAK = DT_RNDM(DUM)*IENTRY+1
+ CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
+ CALL PHO_SWAPD(XP(IPEAK),XP(1))
+ CALL PHO_SWAPI(IV(IPEAK),IV(1))
+ 400 CONTINUE
+C energy limited sampling
+ PSUMX = 0.D0
+ PSUMY = 0.D0
+ ITER = ITER+1
+ IF(ITER.GE.1000) THEN
+ IF(IDEB(6).GE.3) THEN
+ WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
+ & IMODE,IENTRY,ITER
+ WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
+ & IPEAK
+ DO 405 I=1,IENTRY
+ II = MODIFY(I)
+ WRITE(LO,'(5X,3I5,1P,2E13.4)')
+ & I,II,IV(I),XP(I),PHEP(4,II)
+ 405 CONTINUE
+ IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ DO 410 I=2,IENTRY
+ II = MODIFY(I)
+ PTMX = MIN(PHEP(4,II),PTCUT)
+ XPB(1) = XP(I)
+ IVB(1) = IV(I)
+ IF(ISWMDL(5).EQ.0) THEN
+ CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
+ ELSE
+ CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
+ ENDIF
+ PTS(0,I) = PB(0,1)
+ PTS(1,I) = PB(1,1)
+ PTS(2,I) = PB(2,1)
+ PSUMX = PSUMX+PB(1,1)
+ PSUMY = PSUMY+PB(2,1)
+ 410 CONTINUE
+ PTREM = SQRT(PSUMX**2+PSUMY**2)
+ IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
+ PTS(1,1) = -PSUMX
+ PTS(2,1) = -PSUMY
+ ELSE IF((ISWMDL(5).EQ.2)
+ & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
+C unlimited sampling
+ IPEAK = DT_RNDM(PSUMX)*IENTRY+1
+ CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
+ CALL PHO_SWAPD(XP(IPEAK),XP(1))
+ CALL PHO_SWAPI(IV(IPEAK),IV(1))
+ CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
+ ELSE IF(ISWMDL(5).EQ.3) THEN
+C each string has balanced pt
+ DO 500 K=1,IENTRY
+ IF(IV(K).LE.-90) GOTO 499
+ I1 = MODIFY(K)
+ IC1 = -ICOLOR(1,I1)
+ DO 510 L=K+1,IENTRY
+ IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
+ 510 CONTINUE
+ WRITE(LO,'(//1X,A,I5)')
+ & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
+ CALL PHO_ABORT
+ 511 CONTINUE
+ I2 = MODIFY(L)
+ AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
+ & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
+ AM = SQRT(AMSQR)
+ PTMX = AM/2.D0
+ IVB(1) = MAX(IV(K),IV(L))
+ XPB(1) = XP(K)
+ CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
+ PTS(1,K) = PB(1,1)
+ PTS(2,K) = PB(2,1)
+ PTS(1,L) = -PB(1,1)
+ PTS(2,L) = -PB(2,1)
+ GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
+ GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
+ PC(1) = PB(1,1)
+ PC(2) = PB(2,1)
+ PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
+ PC(3) = SIGN(PLONG,PHEP(3,I1))
+ PC(4) = PTMX
+ CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
+ & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
+ PC(1) = -PC(1)
+ PC(2) = -PC(2)
+ PC(3) = -PC(3)
+ CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
+ & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
+ IV(K) = IV(K)-100
+ IV(L) = IV(L)-100
+ 499 CONTINUE
+ 500 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
+ CALL PHO_ABORT
+ ENDIF
+
+C change partons in /POEVT1/
+ DO 900 II=1,IENTRY
+ IF(IV(II).GT.-90) THEN
+ I = MODIFY(II)
+ PHEP(1,I) = PHEP(1,I)+PTS(1,II)
+ PHEP(2,I) = PHEP(2,I)+PTS(2,II)
+ AMSQR = PHEP(4,I)**2
+ & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
+ PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
+ ENDIF
+ 900 CONTINUE
+
+C debug output
+ IF(IDEB(6).GE.15) THEN
+ WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
+ & 'I II IV XP EP PTS PTX PTY',IPEAK
+ DO 505 I=1,IENTRY
+ II = MODIFY(I)
+ WRITE(LO,'(2X,3I5,1P,5E12.4)')
+ & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
+ 505 CONTINUE
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+
+C initialization / output of statistics
+ 1000 CONTINUE
+ CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
+
+ END
+
+*$ CREATE PHO_SOFTPT.FOR
+*COPY PHO_SOFTPT
+CDECK ID>, PHO_SOFTPT
+ SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
+C***********************************************************************
+C
+C select pt of soft string ends
+C
+C input: ISOFT number of soft partons
+C -1 initialization
+C >=0 sampling of p_t
+C -2 output of statistics
+C PTCUT cutoff for soft strings
+C PTMAX maximal allowed PT
+C XV field of x values
+C IV 0 sea quark
+C 1 valence quark
+C
+C output: /POINT3/ containing parameters AAS,BETAS
+C PTSOF filed with soft pt values
+C
+C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
+C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
+C ISWMDL(3/4) = 2 photon wave function
+C ISWMDL(3/4) = 10 no soft P_t assignment
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15)
+
+ DIMENSION PTSOF(0:2,*),XV(*)
+ DIMENSION IV(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DIMENSION BETAB(100)
+
+C selection of pt
+ IF(ISOFT.GE.0) THEN
+ CALLS = CALLS + 1.D0
+C sample according to model ISWMDL(3-6)
+ IF(ISOFT.GT.1) THEN
+ 210 CONTINUE
+ PTXS = 0.D0
+ PTYS = 0.D0
+ DO 300 I=2,ISOFT
+ IMODE = ISWMDL(3)
+C valence partons
+ IF(IV(I).EQ.1) THEN
+ BETA = BETAS(1)
+C photon/pomeron valence part
+ IF(IPAMDL(5).EQ.1) THEN
+ IF(XV(I).GE.0.D0) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ELSE
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ENDIF
+ ELSE IF(IPAMDL(5).EQ.2) THEN
+ BETA = PARMDL(20)
+ ELSE IF(IPAMDL(5).EQ.3) THEN
+ BETA = BETAS(3)
+ ENDIF
+C sea partons
+ ELSE IF(IV(I).EQ.0) THEN
+ BETA = BETAS(3)
+C hard scattering remnant
+ ELSE
+ IF(IPAMDL(6).EQ.0) THEN
+ BETA = BETAS(1)
+ ELSE IF(IPAMDL(6).EQ.1) THEN
+ BETA = BETAS(3)
+ ELSE
+ BETA = PARMDL(20)
+ ENDIF
+ ENDIF
+ BETA = MAX(BETA,0.01D0)
+ CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
+ PTS = MIN(PTMAX,PTS)
+ CALL PHO_SFECFE(SIG,COG)
+ PTSOF(0,I) = PTS
+ PTSOF(1,I) = COG*PTS
+ PTSOF(2,I) = SIG*PTS
+ PTXS = PTXS+PTSOF(1,I)
+ PTYS = PTYS+PTSOF(2,I)
+ BETAB(I) = BETA
+ 300 CONTINUE
+C balancing of momenta
+ PTS = SQRT(PTXS**2+PTYS**2)
+ IF(PTS.GE.PTMAX) GOTO 210
+ PTSOF(0,1) = PTS
+ PTSOF(1,1) = -PTXS
+ PTSOF(2,1) = -PTYS
+ BETAB(1) = 0.D0
+C
+*400 CONTINUE
+C
+C single parton only
+ ELSE
+ IMODE = ISWMDL(3)
+C valence partons
+ IF(IV(1).EQ.1) THEN
+ BETA = BETAS(1)
+C photon/Pomeron valence part
+ IF(IPAMDL(5).EQ.1) THEN
+ IF(XV(1).GE.0.D0) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ELSE
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ENDIF
+ ELSE IF(IPAMDL(5).EQ.2) THEN
+ BETA = PARMDL(20)
+ ELSE IF(IPAMDL(5).EQ.3) THEN
+ BETA = BETAS(3)
+ ENDIF
+C sea partons
+ ELSE IF(IV(1).EQ.0) THEN
+ BETA = BETAS(3)
+C hard scattering remnant
+ ELSE
+ IF(IPAMDL(6).EQ.1) THEN
+ BETA = BETAS(3)
+ ELSE
+ BETA = PARMDL(20)
+ ENDIF
+ ENDIF
+ BETA = MAX(BETA,0.01D0)
+ CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
+ PTS = MIN(PTMAX,PTS)
+ CALL PHO_SFECFE(SIG,COG)
+ PTSOF(0,1) = PTS
+ PTSOF(1,1) = COG*PTS
+ PTSOF(2,1) = SIG*PTS
+ BETAB(1) = BETA
+ ENDIF
+
+C debug output
+ IF(IDEB(29).GE.10) THEN
+ WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
+ WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
+ DO 105 I=1,ISOFT
+ WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
+ & PTSOF(1,I),PTSOF(2,I),BETAB(I)
+ 105 CONTINUE
+ ENDIF
+
+C initialization of statistics and parameters
+
+ ELSE IF(ISOFT.EQ.-1) THEN
+ PTSMIN = 0.D0
+ PTSMAX = PTCUT
+
+ IMODE = -100+ISWMDL(3)
+ CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
+
+C output of statistics
+
+ ELSE IF(ISOFT.EQ.-2) THEN
+
+ ELSE
+ WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
+ & 'unsupported ISOFT ',ISOFT
+ STOP
+ ENDIF
+ END
+
+*$ CREATE PHO_SELPT.FOR
+*COPY PHO_SELPT
+CDECK ID>, PHO_SELPT
+ SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
+C***********************************************************************
+C
+C select pt from different distributions
+C
+C input: EE energy (for initialization only)
+C otherwise x value of corresponding parton
+C PTLOW lower pt limit
+C PTHIGH upper pt limit
+C (PTHIGH > 20 will cause DEXP underflows)
+C
+C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
+C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
+C IMODE = 2 dNs/dP_t according photon wave function
+C IMODE = 10 no sampling
+C
+C IMODE = -100+IMODE initialization according to
+C given limitations
+C
+C output: PTS sampled pt value
+C initialization:
+C BETA soft pt slope in central region
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI2 = 6.28318530718D0,
+ & AMIN = 1.D-2,
+ & EPS = 1.D-7,
+ & DEPS = 1.D-30)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION PHO_CONN0,PHO_CONN1
+ EXTERNAL PHO_CONN0,PHO_CONN1
+
+C initialization
+
+ IF(IMODE.LT.0) GOTO 100
+
+ PX = PTHIGH
+ PTS = 0.D0
+
+C initial checks
+
+ IF(PX.LT.AMIN) RETURN
+
+ IF((PX-PTLOW).LT.0.01) THEN
+ IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
+ & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
+ RETURN
+ ENDIF
+
+C sampling of pt values according to IMODE
+
+ IF(IMODE.EQ.0) THEN
+
+ FAC1 = EXP(-BETA*PX**2)
+ FAC2 = (1.D0-FAC1)
+ 25 CONTINUE
+ XI1 = DT_RNDM(PX)*FAC2 + FAC1
+ PTS = SQRT(-1.D0/BETA*LOG(XI1))
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+ XIMIN = EXP(-BETA*PTHIGH)
+ XIDEL = 1.D0-XIMIN
+ 50 CONTINUE
+ PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
+ & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
+ IF(PTS.LT.XMT) GOTO 50
+ PTS = SQRT(PTS**2-XMT2)
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
+
+ ELSE IF(IMODE.EQ.2) THEN
+
+ IF(EE.GE.0.D0) THEN
+ P2 = PVIRTP(1)
+ ELSE
+ P2 = PVIRTP(2)
+ ENDIF
+ XV = ABS(EE)
+ AA = (1.D0-XV)*XV*P2+PARMDL(25)
+ 75 CONTINUE
+ PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
+
+C something wrong
+
+ ELSE IF(IMODE.NE.10) THEN
+ WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C debug output
+ IF(IDEB(5).GE.20) THEN
+ WRITE(LO,'(1X,A,I3,4E10.3)')
+ & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
+ & IMODE,BETA,PTLOW,PTHIGH,PTS
+ ENDIF
+ RETURN
+
+C initialization
+ 100 CONTINUE
+ PTSMIN = PTLOW
+ PTSMAX = PTHIGH
+ PTCON = PTHIGH
+C calculation of parameters
+ INIT = IMODE+100
+ AAS = 0.D0
+
+C initialization for model 0 (gaussian pt distribution)
+
+ IF(INIT.EQ.0) THEN
+ BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
+ BETUP = BETAS(1)
+ BETLO = -2.D0
+ XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
+ IF(XTOL.LT.0.D0) THEN
+ XTOL = 1.D-4
+ METHOD = 1
+ MAXF = 500
+ BETA = 0.D0
+ BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
+* IF(BETA.LT.-1.D+10) THEN
+* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
+* & '(model 0: Ecm,PTcut)',EE,PTCON
+* WRITE(LO,'(1X,A,1P,3E10.3)')
+* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
+* CALL PHO_PREVNT(-1)
+* BETA = 0.01
+* ELSE
+ AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
+* ENDIF
+ ELSE
+ AAS = 0.D0
+ BETA = BETAS(1)
+ ENDIF
+
+C initialization for model 1 (exponential pt distribution)
+
+ ELSE IF(INIT.EQ.1) THEN
+ XMT = PARMDL(43)
+ XMT2 = XMT*XMT
+ BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
+ BETUP = BETAS(1)
+ BETLO = -3.D0
+ XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
+ IF(XTOL.LT.0.D0) THEN
+ XTOL = 1.D-4
+ METHOD = 1
+ MAXF = 500
+ BETA = 0.D0
+ BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
+* IF(BETA.LT.-1.D+10) THEN
+* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
+* & '(model 1: Ecm,PTcut)',EE,PTCON
+* WRITE(LO,'(1X,A,1P,3E10.3)')
+* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
+* CALL PHO_PREVNT(-1)
+* BETA = 0.01
+* ELSE
+ AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
+* ENDIF
+ ELSE
+ AAS = 0.D0
+ BETA = BETAS(1)
+ ENDIF
+ ELSE IF(INIT.EQ.10) THEN
+ IF(IDEB(5).GT.10)
+ & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
+ RETURN
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
+ & INIT
+ CALL PHO_ABORT
+ ENDIF
+ BETA = MIN(BETA,BETAS(1))
+
+C hard cross section is too big: neg. beta parameter
+ IF(BETA.LE.0.D0) THEN
+ WRITE(LO,'(1X,A,1P,2E12.3)')
+ & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
+ WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
+ & SIGS,DSIGHP,SIGH,PTCON
+ CALL PHO_PREVNT(-1)
+ ENDIF
+
+C output of initialization parameters
+ IF(IDEB(5).GE.10) THEN
+ WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
+ & INIT
+ WRITE(LO,'(5X,A,1P,2E13.3)')
+ & 'BETA,AAS ',BETA,AAS
+ WRITE(LO,'(5X,A,1P,3E13.3)')
+ & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
+ WRITE(LO,'(5X,A,1P,3E13.3)')
+ & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
+ ENDIF
+
+ END
+
+*$ CREATE PHO_CONN0.FOR
+*COPY PHO_CONN0
+CDECK ID>, PHO_CONN0
+ DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
+C***********************************************************************
+C
+C auxiliary function to determine parameters of soft
+C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
+C
+C internal factors: FS number of soft partons in soft Pomeron
+C FH number of soft partons in hard Pomeron
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION BETA,XX,FF
+
+ XX = BETA*PTCON**2
+ IF(ABS(XX).LT.1.D-3) THEN
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
+ ELSE
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
+ ENDIF
+ PHO_CONN0 = FF
+
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
+
+ END
+
+*$ CREATE PHO_CONN1.FOR
+*COPY PHO_CONN1
+CDECK ID>, PHO_CONN1
+ DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
+C***********************************************************************
+C
+C auxiliary function to determine parameters of soft
+C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
+C
+C internal factors: FS number of soft partons in soft Pomeron
+C FH number of soft partons in hard Pomeron
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION BETA,XX,FF
+
+ XX = BETA*PTCON
+ IF(ABS(XX).LT.1.D-3) THEN
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
+ ELSE
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
+ ENDIF
+ PHO_CONN1 = FF
+
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
+
+ END
+
+*$ CREATE PHO_MSHELL.FOR
+*COPY PHO_MSHELL
+CDECK ID>, PHO_MSHELL
+ SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
+C********************************************************************
+C
+C rescaling of momenta of two partons to put both
+C on mass shell
+C
+C input: PA1,PA2 input momentum vectors
+C XM1,2 desired masses of particles afterwards
+C P1,P2 changed momentum vectors
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20 )
+
+ DIMENSION PA1(*),PA2(*),P1(*),P2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+ IDEV = 0
+C debug output
+ IF(IDEB(40).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
+ WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
+ WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
+ ENDIF
+
+C Lorentz transformation into system CMS
+ PX = PA1(1)+PA2(1)
+ PY = PA1(2)+PA2(2)
+ PZ = PA1(3)+PA2(3)
+ EE = PA1(4)+PA2(4)
+ XMS = EE**2-PX**2-PY**2-PZ**2
+ IF(XMS.LT.(XM1+XM2)**2) THEN
+ IREJ = 1
+ IFAIL(37) = IFAIL(37)+1
+
+ if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
+
+ IF(IDEB(40).GE.3) THEN
+ WRITE(LO,'(/1X,A,I12)')
+ & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
+ WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
+ & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
+ WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
+ IDEV = 5
+ IF(IDEB(40).GE.3) GOTO 55
+ ENDIF
+ RETURN
+ ENDIF
+ XMS = SQRT(XMS)
+ BGX = PX/XMS
+ BGY = PY/XMS
+ BGZ = PZ/XMS
+ GAM = EE/XMS
+ CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
+ & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ PTOT1 = MAX(DEPS,PTOT1)
+ COD = P1(3)/PTOT1
+ SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COF = 1.D0
+ SIF = 0.D0
+ IF(PTOT1*SID.GT.1.D-5) THEN
+ COF = P1(1)/(SID*PTOT1)
+ SIF = P1(2)/(SID*PTOT1)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+
+C new CM momentum and energies (for masses XM1,XM2)
+ XM12 = XM1**2
+ XM22 = XM2**2
+ SS = XMS**2
+ PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
+ EE1 = SQRT(XM12+PCMP**2)
+ EE2 = XMS-EE1
+C back rotation
+ CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
+ & PTOT1,P1(1),P1(2),P1(3),P1(4))
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
+ & PTOT2,P2(1),P2(2),P2(3),P2(4))
+
+C check consistency
+ DEL = XMS*0.0001
+ IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
+ IDEV = 1
+ ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
+ IDEV = 2
+ ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
+ IDEV = 3
+ ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
+ IDEV = 4
+ ENDIF
+ 55 CONTINUE
+C debug output
+ IF(IDEV.NE.0) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
+ WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
+ WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
+ WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
+ ELSE IF(IDEB(40).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
+ WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
+ ENDIF
+ END
+
+*$ CREATE PHO_GLU2QU.FOR
+*COPY PHO_GLU2QU
+CDECK ID>, PHO_GLU2QU
+ SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
+C********************************************************************
+C
+C split gluon with index I in POEVT1
+C (massless gluon assumed)
+C
+C input: /POEVT1/
+C IG gluon index
+C IQ1 first quark index
+C IQ2 second quark index
+C
+C output: new quarks in /POEVT1/
+C IREJ 1 splitting impossible
+C 0 splitting successful
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4)
+ DATA CUTM /0.02D0/
+
+ IREJ = 0
+
+C calculate string masses max possible
+ IF(ISWMDL(9).EQ.1) THEN
+ CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
+ & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
+ IF(CMASS1.LT.CUTM) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I4,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+ CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
+ & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
+ IF(CMASS2.LT.CUTM) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I4,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+C
+C calculate minimal z
+ ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
+ ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
+ ZMIN = MIN(ZMIN1,ZMIN2)
+ IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I3,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
+ & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ELSE
+ ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
+ ENDIF
+C
+ ZFRAC = PHO_GLUSPL(ZMIN)
+ IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
+ ZFRAC = 1.D0-ZFRAC
+ ENDIF
+ DO 200 I=1,4
+ P1(I) = PHEP(I,IG)*ZFRAC
+ P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
+ 200 CONTINUE
+C quark flavours
+ CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
+ CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
+ & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
+ CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
+
+ IF(ABS(IDHEP(IQ1)).GT.6) THEN
+ K = SIGN(ABS(K),IDHEP(IQ1))
+ ELSE
+ K = -SIGN(ABS(K),IDHEP(IQ1))
+ ENDIF
+C colors
+ IF(K.GT.0) THEN
+ IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
+ IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
+ ELSE
+ IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
+ IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
+ ENDIF
+C register new partons
+ CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
+ & IPHIST(1,IG),0,IC1,0,IPOS,1)
+ CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
+ & IPHIST(1,IG),0,IC2,0,IPOS,1)
+C debug output
+ IF(IDEB(73).GE.20) THEN
+ WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
+ & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
+ & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
+ WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
+ & K,-K,IC1,IC2
+ ENDIF
+ END
+
+*$ CREATE PHO_GLUSPL.FOR
+*COPY PHO_GLUSPL
+CDECK ID>, PHO_GLUSPL
+ DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
+C*********************************************************************
+C
+C calculate quark - antiquark light cone momentum fractions
+C according to Altarelli-Parisi g->q aq splitting function
+C (symmetric z interval assumed)
+C
+C input: ZMIN minimal Z value allowed,
+C 1-ZMIN maximal Z value allowed
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( ALEXP= 0.3333333333D0,
+ & DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+ IF(ZMIN.GE.0.5D0) THEN
+ IF(IDEB(69).GT.2) THEN
+ WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
+ ENDIF
+ ZZ=0.D0
+ GOTO 1000
+ ELSE IF(ZMIN.LE.0.D0) THEN
+ IF(IDEB(69).GT.2) THEN
+ WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
+ ENDIF
+ ZMINL = DEPS
+ ELSE
+ ZMINL = ZMIN
+ ENDIF
+
+ ZMAX = 1.D0-ZMINL
+ XI = DT_RNDM(ZMAX)
+ ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
+ IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
+
+ 1000 CONTINUE
+ IF(IDEB(69).GE.10) THEN
+ WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
+ ENDIF
+ PHO_GLUSPL = ZZ
+ END
+
+*$ CREATE PHO_STDPAR.FOR
+*COPY PHO_STDPAR
+CDECK ID>, PHO_STDPAR
+ SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+C***********************************************************************
+C
+C select the initial parton x-fractions and flavors and
+C the final parton momenta and flavours
+C for standard Pomeron/Reggeon cuts
+C
+C input: IJM1 index of mother particle 1 in /POEVT1/
+C IJM2 index of mother particle 2 in /POEVT1/
+C IGEN production process of mother particles
+C MSPOM soft cut Pomerons
+C MHPOM hard or semihard cut Pomerons
+C MSREG soft cut Reggeons
+C MHDIR direct hard processes
+C
+C IJM1 -1 initialization of statistics
+C -2 output of statistics
+C
+C output: partons are directly written to /POEVT1/,/POEVT2/
+C
+C structure of /POSOFT/
+C XS1(I),XS2(I): x-values of initial partons
+C IJSI1(I),IJSI2(I): flavor of initial parton
+C 0 gluon
+C 1,2,3,4 quarks
+C negative antiquarks
+C IJSF1(I),IJSF2(I): flavor of final state partons
+C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
+C J=1 PX
+C =2 PY
+C =3 PZ
+C =4 ENERGY
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (RHOMAS = 0.766D0,
+ & DEPS = 1.D-10,
+ & TINY = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C internal cross check information on hard scattering limits
+ DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
+ COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+ double precision pho_alphas
+
+ DIMENSION PC(4),IFLA(2),ICI(2,2)
+
+ IF(IJM1.EQ.-1) THEN
+ DO 116 I=1,15
+ ETAMI(1,I) = 1.D10
+ ETAMA(1,I) = -1.D10
+ ETAMI(2,I) = 1.D10
+ ETAMA(2,I) = -1.D10
+ XXMI(1,I) = 1.D0
+ XXMA(1,I) = 0.D0
+ XXMI(2,I) = 1.D0
+ XXMA(2,I) = 0.D0
+ 116 CONTINUE
+ CALL PHO_HARSCA(IJM1,1)
+ CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
+
+ RETURN
+
+ ELSE IF(IJM1.EQ.-2) THEN
+
+C output internal statistics
+ IF(IDEB(23).GE.1) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
+ DO 117 I=1,15
+ WRITE(LO,'(5X,I3,4E13.5)')
+ & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
+ 117 CONTINUE
+ WRITE(LO,'(1X,A)')
+ & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
+ DO 118 I=1,15
+ WRITE(LO,'(5X,I3,4E13.5)')
+ & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
+ 118 CONTINUE
+ ENDIF
+ CALL PHO_HARSCA(IJM1,1)
+ CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
+
+ RETURN
+ ENDIF
+
+ IREJ = 0
+C debug output
+ IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
+ 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
+
+C get mother data (exchange if first particle is a pomeron)
+ IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
+ JM1 = IJM2
+ JM2 = IJM1
+ ELSE
+ JM1 = IJM1
+ JM2 = IJM2
+ ENDIF
+
+ NPOSP(1) = JM1
+ NPOSP(2) = JM2
+ IDPDG1 = IDHEP(JM1)
+ IDBAM1 = IMPART(JM1)
+ IDPDG2 = IDHEP(JM2)
+ IDBAM2 = IMPART(JM2)
+
+C store current status of /POEVT1/
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ NHEPS = NHEP
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+
+C get nominal masses (photons: VDM assumption)
+ DELMAS = 0.D0
+ IF(IDHEP(JM1).EQ.22) THEN
+ PMASSP(1) = RHOMAS+DELMAS
+ PVIRTP(1) = PHEP(5,JM1)**2
+ ELSE
+ PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
+ PVIRTP(1) = 0.D0
+ ENDIF
+ IF(IDHEP(JM2).EQ.22) THEN
+ PMASSP(2) = RHOMAS+DELMAS
+ PVIRTP(2) = PHEP(5,JM2)**2
+ ELSE
+ PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
+ PVIRTP(2) = 0.D0
+ ENDIF
+
+C calculate c.m. energy and check kinematics
+ PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
+
+ IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
+ WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
+ & 'energy smaller than two-particle threshold (event rejected)'
+ CALL PHO_PREVNT(1)
+ IREJ = 5
+ GOTO 150
+ ENDIF
+ ECMP = SQRT(SS)
+
+ IF(IDEB(23).GE.5) THEN
+ WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
+ & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
+ IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
+ ENDIF
+
+C Lorentz transformation into c.m. system
+ DO 10 I=1,4
+ GAMBEP(I) = PC(I)/ECMP
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
+ & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
+ & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
+C rotation angle: particle 1 moves along +z
+ CODP = PC(3)/PTOT1
+ SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
+ COFP = 1.D0
+ SIFP = 0.D0
+ IF(PTOT1*SIDP.GT.1.D-5) THEN
+ COFP = PC(1)/(SIDP*PTOT1)
+ SIFP = PC(2)/(SIDP*PTOT1)
+ ANORF = SQRT(COFP*COFP+SIFP*SIFP)
+ COFP = COFP/ANORF
+ SIFP = SIFP/ANORF
+ ENDIF
+C get CM momentum
+ XM12 = PMASSP(1)**2
+ XM22 = PMASSP(2)**2
+ PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
+
+C find particle combination
+ II = 0
+ IF(IDPDG2.EQ.IFPAP(2)) THEN
+ IF(IDPDG1.EQ.IFPAP(1)) II = 1
+ ELSE IF(IDPDG2.EQ.990) THEN
+ IF(IDPDG1.EQ.IFPAP(1)) THEN
+ II = 2
+ ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
+ II = 3
+ ELSE IF(IDPDG1.EQ.990) THEN
+ II = 4
+ ENDIF
+ ENDIF
+ IF(II.EQ.0) THEN
+ IF(ISWMDL(14).GT.0) THEN
+ II = 1
+ ELSE
+ WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
+ & 'invalid particle combination:',IDPDG1,IDPDG2
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+
+C select parton distribution functions from tables
+ IF((MHPOM+MHDIR).GT.0) THEN
+ CALL PHO_ACTPDF(IDPDG1,1)
+ CALL PHO_ACTPDF(IDPDG2,2)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+ ENDIF
+
+C interpolate hard cross sections and rejection weights
+ CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
+
+ NTRY = 10
+
+C position of first particle added to /POEVT2/
+ NLOR1 = NHEP+1
+
+C ---------------- direct processes -----------------
+
+ IF(MHDIR.EQ.1) THEN
+ CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
+ IF(IREJ.EQ.50) RETURN
+ IF(IREJ.NE.0) GOTO 150
+C write comments to /POEVT1/
+ CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
+ & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
+ & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
+ CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
+ & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
+ & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
+ & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
+ & IPOS1,1)
+ CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
+ & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
+ & IPOS2,1)
+
+C soft spectator partons
+ ICA1 = 0
+ ICA2 = 0
+ ICB1 = 0
+ ICB2 = 0
+ IPDF1 = 0
+ IPDF2 = 0
+
+C single resolved: QCD compton scattering
+C ------------------------------
+ IF(NPROHD(1).EQ.10) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
+ IPDF2 = 1000*IGRP(2)+ISET(2)
+ ELSE IF(NPROHD(1).EQ.12) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
+ IPDF1 = 1000*IGRP(1)+ISET(1)
+
+C single resolved: photon gluon fusion
+C ---------------------------
+ ELSE IF(NPROHD(1).EQ.11) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
+ IPDF2 = 1000*IGRP(2)+ISET(2)
+ ELSE IF(NPROHD(1).EQ.13) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
+ IPDF1 = 1000*IGRP(1)+ISET(1)
+
+C direct process (no remnant)
+C ----------------------------
+ ELSE IF(NPROHD(1).EQ.14) THEN
+
+ ENDIF
+
+C write final high-pt partons to POEVT1
+ IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
+ ICI(1,1) = ICA1
+ ICI(1,2) = ICA2
+ ICI(2,1) = ICB1
+ ICI(2,2) = ICB2
+ I = 1
+ IFLA(1) = NINHD(I,1)
+ IFLA(2) = NINHD(I,2)
+C initial state radiation
+ DO 130 K=1,2
+ DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
+ KK = 1
+ 137 CONTINUE
+ IFLB = IFLISR(K,IPA)
+ IF(ABS(IFLB).LE.6) THEN
+C partons
+ IF(ICI(K,1)*ICI(K,2).NE.0) THEN
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),3)
+ ELSE IF(IFLB.GT.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),4)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
+ & IC1,IC2,4)
+ ENDIF
+ ELSE
+ IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
+ IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
+ CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
+ KK = KK+1
+ GOTO 137
+ ENDIF
+ ENDIF
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
+ & IC1,IC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),2)
+ ENDIF
+ ENDIF
+ IIFL = IPHO_CNV1(IFLB)
+
+ IFLA(K) = IFLA(K)-IFLB
+ IST = -1
+ ELSE
+C other particle
+ IIFL = IFLB
+ IC1 = 0
+ IC2 = 0
+ IST = 1
+ ENDIF
+ CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
+ & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
+ & IGEN,IC1,IC2,IPOS,1)
+ 135 CONTINUE
+ 130 CONTINUE
+ ICOLOR(1,IPOS1-2) = ICI(1,1)
+ ICOLOR(2,IPOS1-2) = ICI(1,2)
+ ICOLOR(1,IPOS1-1) = ICI(2,1)
+ ICOLOR(2,IPOS1-1) = ICI(2,2)
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
+ & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
+ & NOUTHD(I,2),ICI(2,1),ICI(2,2))
+ ICOLOR(1,IPOS1) = ICI(1,1)
+ ICOLOR(2,IPOS1) = ICI(1,2)
+ ICOLOR(1,IPOS2) = ICI(2,1)
+ ICOLOR(2,IPOS2) = ICI(2,2)
+ DO 140 K=1,2
+ IPA = IPOISR(K,1,I)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
+ & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
+ & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
+ 140 CONTINUE
+ ELSE
+ ICOLOR(1,IPOS1-2) = ICA1
+ ICOLOR(2,IPOS1-2) = ICA2
+ ICOLOR(1,IPOS1-1) = ICB1
+ ICOLOR(2,IPOS1-1) = ICB2
+ CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
+ & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
+ & NOUTHD(1,2),ICB1,ICB2)
+ ICOLOR(1,IPOS1) = ICA1
+ ICOLOR(2,IPOS1) = ICA2
+ ICOLOR(1,IPOS2) = ICB1
+ ICOLOR(2,IPOS2) = ICB2
+ I = -1
+ IF(ABS(NOUTHD(1,1)).GT.12) I = 1
+ CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
+ & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
+ & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
+ ENDIF
+
+C assign soft pt to spectators
+ IF(ISWMDL(18).EQ.0) THEN
+ IPOS2 = IPOS2-1
+ CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(26) = IFAIL(26) + 1
+ GOTO 150
+ ENDIF
+
+ ENDIF
+
+C ----------------- resolved processes -------------------
+
+C single Reggeon exchange
+C ----------------------------
+ ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
+C flavours
+ CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(24) = IFAIL(24)+1
+ GOTO 150
+ ENDIF
+
+C colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
+ & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
+ CALL PHO_SWAPI(ICA1,ICB1)
+ ENDIF
+ ECMH = ECMP/2.D0
+
+C registration
+
+C DPMJET call with special projectile / target
+**sr leading tab removed
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
+**
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
+ & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
+ & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
+C default treatment
+ ELSE
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
+ & -1,IGEN,ICA1,0,IPOS1,1)
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
+ & -1,IGEN,ICB1,0,IPOS2,1)
+ ENDIF
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+C
+C multi Reggeon / Pomeron exchange
+C----------------------------------------
+ ELSE
+C parton configuration
+
+ CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
+ & MHPAR1,MHPAR2,IREJ)
+
+ IF(IREJ.EQ.50) RETURN
+ IF(IREJ.NE.0) GOTO 150
+
+C register particles
+ IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
+ & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
+ & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
+
+C register soft partons
+ IF(IVAL1.NE.0) THEN
+ IF(IVAL1.LT.0) THEN
+ IND1 = 3
+ IVAL1=-IVAL1
+ ELSE
+ IND1 = 2
+ ENDIF
+ ELSE IF(MSPOM.EQ.0) THEN
+ IND1 = 4
+ ELSE
+ IND1 = 1
+ ENDIF
+ IF(IVAL2.NE.0) THEN
+ IF(IVAL2.LT.0) THEN
+ IND2 = 3
+ IVAL2=-IVAL2
+ ELSE
+ IND2 = 2
+ ENDIF
+ ELSE IF(MSPOM.EQ.0) THEN
+ IND2 = 4
+ ELSE
+ IND2 = 1
+ ENDIF
+
+ IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
+ & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
+
+C soft Pomeron final states
+C -----------------------------------
+ K = MSPOM+MHPOM+MSREG
+ DO 50 I=1,MSPOM
+
+ CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(8) = IFAIL(8) + 1
+ GOTO 150
+ ENDIF
+C
+ 50 CONTINUE
+
+C soft Reggeon final states
+C -----------------------------------------
+ DO 75 I=1,MSREG
+C flavours
+ CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
+ IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
+ CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
+ ELSE
+ CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
+ ENDIF
+
+C colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
+ & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
+ & CALL PHO_SWAPI(ICA1,ICB1)
+C registration
+ CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
+ & I,IGEN,ICA1,ICA2,IPOS1,1)
+ IND1 = IND1+1
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
+ & I,IGEN,ICB1,ICB2,IPOS2,1)
+ IND2 = IND2+1
+
+ IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
+ & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
+ & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+ 75 CONTINUE
+
+C hard Pomeron final states
+C ------------------------------------
+ IND1 = MSPAR1
+ IND2 = MSPAR2
+
+ DO 100 L=1,MHPOM
+ I = LSIDX(L)
+
+ IFLI1 = IPHO_CNV1(N0INHD(I,1))
+ IFLI2 = IPHO_CNV1(N0INHD(I,2))
+ IFLO1 = IPHO_CNV1(NOUTHD(I,1))
+ IFLO2 = IPHO_CNV1(NOUTHD(I,2))
+
+C write comments to /POEVT1/
+ CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
+ & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
+ & IFLO1,IFLO2,IPOS,1)
+ I1 = 8*I-7
+ IPDF = 1000*IGRP(1)+ISET(1)
+ CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
+ & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
+ & ICA1,ICA2,IPOS,1)
+ IPDF = 1000*IGRP(2)+ISET(2)
+ CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
+ & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
+ & ICB1,ICB2,IPOS,1)
+ I1 = 8*I-3
+ IPDF = 1000*IGRP(1)+ISET(1)
+ CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
+ & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
+ & ICA1,ICA2,IPOS1,1)
+ IPDF = 1000*IGRP(2)+ISET(2)
+ CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
+ & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
+ & ICB1,ICB2,IPOS2,1)
+
+C spectator partons belonging to hard interaction
+ IF(IVAL1.EQ.I) THEN
+ IVQ = 1
+ IND = 1
+ ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
+ IVQ = 0
+ IND = 1
+ ELSE
+ IVQ = -1
+ IND = IND1
+ ENDIF
+ CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
+ IF(IVQ.LT.0) IND1 = IND1-IUSED
+ IF(IVAL2.EQ.I) THEN
+ IVQ = 1
+ IND = 1
+ ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
+ IVQ = 0
+ IND = 1
+ ELSE
+ IVQ = -1
+ IND = IND2
+ ENDIF
+ CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
+ IF(IVQ.LT.0) IND2 = IND2-IUSED
+C
+C register hard scattered partons
+ IF((ISWMDL(8).GE.2)
+ & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
+ ICI(1,1) = ICA1
+ ICI(1,2) = ICA2
+ ICI(2,1) = ICB1
+ ICI(2,2) = ICB2
+ IFLA(1) = NINHD(I,1)
+ IFLA(2) = NINHD(I,2)
+C initial state radiation
+ DO 230 K=1,2
+ DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
+ KK = 1
+ 237 CONTINUE
+ IFLB = IFLISR(K,IPA)
+ IF(ABS(IFLB).LE.6) THEN
+C partons
+ IF(ICI(K,1)*ICI(K,2).NE.0) THEN
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),3)
+ ELSE IF(IFLB.GT.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),4)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
+ & ICI(K,2),IC1,IC2,4)
+ ENDIF
+ ELSE
+ IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
+ IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
+ CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
+ KK = KK+1
+ GOTO 237
+ ENDIF
+ ENDIF
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
+ & ICI(K,2),IC1,IC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),2)
+ ENDIF
+ ENDIF
+ IIFL = IPHO_CNV1(IFLB)
+
+ IFLA(K) = IFLA(K)-IFLB
+ IST = -1
+ ELSE
+C other particles
+ IIFL = IFLB
+ IC1 = 0
+ IC2 = 0
+ IST = 1
+ ENDIF
+ CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
+ & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
+ & L*100+K,IGEN,IC1,IC2,IPOS,1)
+ 235 CONTINUE
+ 230 CONTINUE
+ ICOLOR(1,IPOS1-2) = ICI(1,1)
+ ICOLOR(2,IPOS1-2) = ICI(1,2)
+ ICOLOR(1,IPOS1-1) = ICI(2,1)
+ ICOLOR(2,IPOS1-1) = ICI(2,2)
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
+ & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
+ & NOUTHD(I,2),ICI(2,1),ICI(2,2))
+ ICOLOR(1,IPOS1) = ICI(1,1)
+ ICOLOR(2,IPOS1) = ICI(1,2)
+ ICOLOR(1,IPOS2) = ICI(2,1)
+ ICOLOR(2,IPOS2) = ICI(2,2)
+ DO 240 K=1,2
+ IPA = IPOISR(K,1,I)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
+ & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
+ & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
+ 240 CONTINUE
+ ELSE
+ ICOLOR(1,IPOS1-2) = ICA1
+ ICOLOR(2,IPOS1-2) = ICA2
+ ICOLOR(1,IPOS1-1) = ICB1
+ ICOLOR(2,IPOS1-1) = ICB2
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
+ & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
+ & NOUTHD(I,2),ICB1,ICB2)
+ ICOLOR(1,IPOS1) = ICA1
+ ICOLOR(2,IPOS1) = ICA2
+ ICOLOR(1,IPOS2) = ICB1
+ ICOLOR(2,IPOS2) = ICB2
+ I1 = 8*I-3
+ CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
+ & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
+ & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
+ & ICB1,ICB2,IPOS,1)
+ ENDIF
+ 100 CONTINUE
+C end of resolved parton registration
+ ENDIF
+
+ IF(MHDIR+MHPOM.GT.0) THEN
+
+ IF(ISWMDL(29).GE.1) THEN
+C primordial kt of hard scattering
+ CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(27) = IFAIL(27)+1
+ GOTO 150
+ ENDIF
+ ELSE IF(ISWMDL(24).GE.0) THEN
+C give "soft" pt only to soft (spectator) partons in hard processes
+ CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(26) = IFAIL(26)+1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+C give "soft" pt to partons in soft Pomerons
+ IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
+ CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+C boost back to lab frame
+ CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
+ & GAMBEP(1),GAMBEP(2),GAMBEP(3))
+ RETURN
+
+C rejection treatment
+ 150 CONTINUE
+ IFAIL(2) = IFAIL(2)+1
+C reset counters
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+C reset mother-daugther relations
+ JDAHEP(1,JM1) = 0
+ JDAHEP(2,JM1) = 0
+ JDAHEP(1,JM2) = 0
+ JDAHEP(2,JM2) = 0
+ ISTHEP(JM1) = 1
+ ISTHEP(JM2) = 1
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ NHEP = NHEPS
+C debug
+ IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
+ & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
+ & MSPOM,MHPOM,MSREG,MHDIR
+ RETURN
+
+ END
+
+*$ CREATE PHO_HARCOL.FOR
+*COPY PHO_HARCOL
+CDECK ID>, PHO_HARCOL
+ SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
+ & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
+C*********************************************************************
+C
+C calculate color flow for hard resolved process
+C
+C input: IP1..4 flavour of partons (PDG convention)
+C V parton subprocess Mandelstam variable V = t/s
+C (lightcone momenta assumed)
+C ICA,ICB color labels
+C MSPR process number
+C -1 initialization of statistics
+C -2 output of statistics
+C
+C output: ICC,ICD color label of final partons
+C
+C (it is possible to use the same variables for in and output)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+
+ DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
+
+C initialization
+ IF(MSPR.EQ.-1) THEN
+ DO 200 I=1,8
+ DO 210 K=1,5
+ ICONF(I,K) = 0
+ 210 CONTINUE
+ IRECN(I,1) = 0
+ IRECN(I,2) = 0
+ 200 CONTINUE
+ RETURN
+C output of statistics
+ ELSE IF(MSPR.EQ.-2) THEN
+ IF(IDEB(26).LT.1) RETURN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_HARCOL: sampled color configurations',
+ & '----------------------------------------'
+ WRITE(LO,'(6X,A,15X,A)')
+ & 'diagram color configurations (1-4)','sum'
+ DO 300 I=1,8
+ DO 310 K=1,4
+ ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
+ 310 CONTINUE
+ WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
+ 300 CONTINUE
+ IF(ISWMDL(11).GE.2) THEN
+ WRITE(LO,'(/6X,A)')
+ & 'diagram with / without color re-connection'
+ DO 320 I=1,8
+ WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
+ 320 CONTINUE
+ ENDIF
+ RETURN
+ ENDIF
+C
+C gluons: first color positive, quarks second color zero
+ IF(IP1.EQ.0) THEN
+ IF(ICA1.LT.0) THEN
+ I = ICA2
+ ICA2 = ICA1
+ ICA1 = I
+ ENDIF
+ ELSE
+ ICA2 = 0
+ ENDIF
+ IF(IP2.EQ.0) THEN
+ IF(ICB1.LT.0) THEN
+ I = ICB2
+ ICB2 = ICB1
+ ICB1 = I
+ ENDIF
+ ELSE
+ ICB2 = 0
+ ENDIF
+ IC2 = 0
+ IC4 = 0
+C debug output
+ IF(IDEB(26).GE.15)
+ & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
+ & 'PHO_HARCOL: process',MSPR,
+ & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+C
+ IRC = 0
+ IF(IPAMDL(21).EQ.1) THEN
+C
+C soft color re-connection option
+C
+ IF(MSPR.EQ.1) THEN
+C hard g g final state, only g g --> g g
+ IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
+ IF(DT_RNDM(V).LT.PARMDL(140)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C hard q g final state
+ IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
+ IF(DT_RNDM(V).LT.PARMDL(141)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
+C hard q q final state
+ IF(ICA1.NE.-ICB1) THEN
+ IF(DT_RNDM(V).LT.PARMDL(142)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ENDIF
+ IRECN(MSPR,2) = IRECN(MSPR,2)+1
+ ENDIF
+C
+ IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
+C
+C large Nc limit of all graphs
+C
+ IF(MSPR.EQ.1) THEN
+C g g --> g g
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB2
+ IC3 = ICB1
+ IC4 = ICA2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.2) THEN
+C q qb --> g g
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(ICA1.LT.0) THEN
+ IC1 = I1
+ IC2 = ICA1
+ IC3 = ICB1
+ IC4 = I2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C q g --> q g
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IF(IP1+IP2.GT.0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = ICB2
+ IC3 = ICB1
+ IC4 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB1
+ IC3 = ICA2
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(IP1.GT.0) THEN
+ CALL PHO_HARCOR(-ICA1,ICB2)
+ IC1 = ICA1
+ IC3 = ICB1
+ IC4 = -ICA1
+ ELSE IF(IP2.GT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IC1 = ICA1
+ IC2 = -ICB1
+ IC3 = ICB1
+ ELSE IF(IP1.LT.0) THEN
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ IC1 = ICA1
+ IC3 = -ICA1
+ IC4 = ICB2
+ ELSE IF(IP2.LT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ IC1 = -ICB1
+ IC2 = ICA2
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.4) THEN
+C g g --> q qb
+ IC1 = ICA1
+ IC3 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC3 = ICA2
+ IF(IP3*IC1.LT.0) THEN
+ I = IC1
+ IC1 = IC3
+ IC3 = I
+ ENDIF
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE IF(MSPR.EQ.5) THEN
+C q qb --> q qb
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = -ICA1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = -ICA1
+ ENDIF
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.6) THEN
+C q qb --> qp qbp
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.7) THEN
+C q q --> q q
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.8) THEN
+C q qp --> q qp
+ IF(IP1*IP2.GT.0) THEN
+ IF(IP3.EQ.IP1) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = -ICA1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = -ICA1
+ ENDIF
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+C unknown process
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+C
+ ELSE
+C
+C color flow according to QCD leading order matrix element
+C
+ U = -(1.D0+V)
+ IF(MSPR.EQ.1) THEN
+C g g --> g g
+ PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
+ PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
+ PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
+ XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
+ PCS = 0.D0
+ DO 110 I=1,3
+ PCS = PCS+PC(I)
+ IF(XI.LT.PCS) GOTO 120
+ 110 CONTINUE
+ 120 CONTINUE
+ IF(I.EQ.1) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = I1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC4 = ICA2
+ ENDIF
+ ELSE IF(I.EQ.2) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(DT_RNDM(U).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICA2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC1 = ICA1
+ ELSE
+ IC1 = I1
+ IC2 = ICB2
+ IC3 = ICA1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC2 = ICA2
+ ENDIF
+ ELSE
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB2
+ IC3 = ICB1
+ IC4 = ICA2
+ ENDIF
+ ENDIF
+ ICONF(MSPR,I) = ICONF(MSPR,I)+1
+ ELSE IF(MSPR.EQ.2) THEN
+C q qb --> g g
+ PC(1) = U/V-2.D0*U**2
+ PC(2) = V/U-2.D0*V**2
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IF(ICA1.GT.0) THEN
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I1
+ IC2 = ICA1
+ IC3 = ICB1
+ IC4 = I2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(ICA1.GT.0) THEN
+ IC1 = I1
+ IC2 = ICB1
+ IC3 = ICA1
+ IC4 = I2
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = ICB1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICA1
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C q g --> q g
+ PC(1) = 2.D0*(U/V)**2-U
+ PC(2) = 2.D0/V**2-1.D0/U
+ XI = (PC(1)+PC(2))*DT_RNDM(V)
+ IF(XI.LT.PC(1)) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP1.GT.0) THEN
+ IC1 = I1
+ IC3 = ICB1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICA1,ICB2)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = I2
+ IC3 = I1
+ IC4 = ICB2
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE IF(IP2.GT.0) THEN
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE
+ IC1 = I1
+ IC2 = ICA2
+ IC3 = I2
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP1.GT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ IC4 = ICB2
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = ICB2
+ IC3 = ICB1
+ IC4 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE IF(IP2.GT.0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB1
+ IC3 = ICA2
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.4) THEN
+C g g --> q qb
+ PC(1) = U/V-2.D0*U**2
+ PC(2) = V/U-2.D0*V**2
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IF(IP3.GT.0) THEN
+ IC1 = ICA1
+ IC3 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC3 = ICA2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA2
+ IC3 = ICB1
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC3 = ICA1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP3.GT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC1 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = ICB2
+ IC3 = ICA1
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC1 = ICA2
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.5) THEN
+C q qb --> q qb
+ PC(1) = (1.D0+U**2)/V**2
+ PC(2) = (V**2+U**2)
+ XI = (PC(1)+PC(2))*DT_RNDM(V)
+ IF(XI.LT.PC(1)) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP3.GT.0) THEN
+ IC1 = I1
+ IC3 = I2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I2
+ IC3 = I1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP3.GT.0) THEN
+ IC1 = MAX(ICA1,ICB1)
+ IC3 = MIN(ICA1,ICB1)
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = MIN(ICA1,ICB1)
+ IC3 = MAX(ICA1,ICB1)
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.6) THEN
+C q qb --> qp qpb
+ IF(IP3.GT.0) THEN
+ IC1 = MAX(ICA1,ICB1)
+ IC3 = MIN(ICA1,ICB1)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = MIN(ICA1,ICB1)
+ IC3 = MAX(ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.7) THEN
+C q q --> q q
+ PC(1) = (1.D0+U**2)/V**2
+ PC(2) = (1.D0+V**2)/U**2
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.8) THEN
+C q qp --> q qp
+ IF(IP1*IP2.LT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP1.GT.0) THEN
+ IC1 = I1
+ IC3 = I2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I2
+ IC3 = I1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ENDIF
+
+ ELSE IF(MSPR.EQ.10) THEN
+C gam q --> q g
+ CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
+ IF(IP3.EQ.0) THEN
+ CALL PHO_SWAPI(IC1,IC3)
+ CALL PHO_SWAPI(IC2,IC4)
+ ENDIF
+ ELSE IF(MSPR.EQ.11) THEN
+C gam g --> q q
+ IC1 = ICB1
+ IC3 = ICB2
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ELSE IF(MSPR.EQ.12) THEN
+C q gam --> q g
+ CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
+ IF(IP3.EQ.0) THEN
+ CALL PHO_SWAPI(IC1,IC3)
+ CALL PHO_SWAPI(IC2,IC4)
+ ENDIF
+ ELSE IF(MSPR.EQ.13) THEN
+C g gam --> q q
+ IC1 = ICA1
+ IC3 = ICA2
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ELSE IF(MSPR.EQ.14) THEN
+ IF(ABS(IP3).GT.12) THEN
+ IC1 = 0
+ IC3 = 0
+ ELSE
+ CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ENDIF
+ ELSE
+C unknown process
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARCOL:ERROR:invalid process number',MSPR
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+ 100 CONTINUE
+C debug output
+ IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
+ & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
+C color connection?
+* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
+* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
+* & .OR.(IC2.EQ.0))) THEN
+C color exchange?
+* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
+* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
+* IF(IRC.NE.1) THEN
+* WRITE(LO,'(1X,A,I10,I3)')
+* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
+* ENDIF
+* IRC = 0
+* ENDIF
+* ENDIF
+* IF(IRC.EQ.1) THEN
+* WRITE(LO,'(1X,A,I10,I3)')
+* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
+* ENDIF
+C
+ ICC1 = IC1
+ ICC2 = IC2
+ ICD1 = IC3
+ ICD2 = IC4
+
+ END
+
+*$ CREATE PHO_HARCOR.FOR
+*COPY PHO_HARCOR
+CDECK ID>, PHO_HARCOR
+ SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
+C***********************************************************************
+C
+C substituite color in /POEVT2/
+C
+C input: ICOLD old color
+C ICNEW new color
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DO 100 I=NHEP,3,-1
+ IF(ISTHEP(I).EQ.-1) THEN
+ IF(ICOLOR(1,I).EQ.ICOLD) THEN
+ ICOLOR(1,I) = ICNEW
+ RETURN
+ ELSE IF(IDHEP(I).EQ.21) THEN
+ IF(ICOLOR(2,I).EQ.ICOLD) THEN
+ ICOLOR(2,I) = ICNEW
+ RETURN
+ ENDIF
+ ENDIF
+* ELSE IF(ISTHEP(I).EQ.20) THEN
+* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
+* write(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
+* ICOLOR(1,I) = -ICNEW
+* RETURN
+* ELSE IF(IDHEP(I).EQ.21) THEN
+* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
+* write(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
+* ICOLOR(2,I) = -ICNEW
+* RETURN
+* ENDIF
+* ENDIF
+ ENDIF
+ 100 CONTINUE
+ END
+
+*$ CREATE PHO_HARREM.FOR
+*COPY PHO_HARREM
+CDECK ID>, PHO_HARREM
+ SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
+ & IUSED,IREJ)
+C***********************************************************************
+C
+C sample color structure for initial quark/gluon of hard scattering
+C and write hadron remnant to /POEVT1/
+C
+C input: JM1,2 index of mother particle in POEVT1
+C IGEN mother particle production process
+C IHPOS hard pomeron number
+C INDXH index of hard parton
+C positive for labels 1
+C negative for labels 2
+C IVAL 1 hard valence parton
+C 0 hard sea parton connected by color flow with
+C valence quarks
+C -1 hard sea parton independent off valence
+C quarks
+C INDXS index of soft partons needed
+C
+C output: IC1,IC2 color label of initial parton
+C IUSED number of soft X values used
+C IREJ rejection flag
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+
+ INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
+
+ IF(INDXH.GT.0) THEN
+ IJH = IPHO_CNV1(NINHD(INDXH,1))
+ ELSE
+ IJH = IPHO_CNV1(NINHD(-INDXH,2))
+ ENDIF
+C direct process (photon or pomeron)
+ IUSED = 0
+ IC1 = 0
+ IC2 = 0
+ IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
+
+ IHP = 100*ABS(IHPOS)
+ IVSW = 1
+***************************************
+* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
+***************************************
+
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
+ & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
+ & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
+
+C quark
+C****************************************************************
+
+ IF(IJH.NE.21) THEN
+
+C valence quark engaged in hard scattering
+ IF(IVAL.EQ.1) THEN
+ CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
+ IF(IREJ.NE.0) THEN
+ WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
+ & 'invalid valence flavour requested JM,IFLA',JM1,IJH
+ return
+ ENDIF
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
+ & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IREM
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IREM
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IREM,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 1
+
+C sea quark engaged in hard scattering, valence quarks treated
+ ELSE IF(IVAL.EQ.0) THEN
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(DT_RNDM(P1).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ENDIF
+ IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
+ & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IVFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IVFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IVFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IVFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IVFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+C
+ IF(IJH.LT.0) THEN
+ ICB1 = ICC2
+ ICA1 = ICC1
+ ELSE
+ ICB1 = ICC1
+ ICA1 = ICC2
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+2)
+ P2 = PSOFT1(2,INDXS+2)
+ P3 = PSOFT1(3,INDXS+2)
+ P4 = PSOFT1(4,INDXS+2)
+ IJSI1(INDXS+2) = -IJH
+ ELSE
+ P1 = PSOFT2(1,INDXS+2)
+ P2 = PSOFT2(2,INDXS+2)
+ P3 = PSOFT2(3,INDXS+2)
+ P4 = PSOFT2(4,INDXS+2)
+ IJSI2(INDXS+2) = -IJH
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & -IJH,IPOS,SIGN(INDXS+2,INDXH)
+ IUSED = 3
+C
+C sea quark engaged in hard scattering, valences treated separately
+ ELSE IF(IVAL.EQ.-1) THEN
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(IJH.GT.0) THEN
+ ICC1 = ICB1
+ ICB1 = ICA1
+ ICA1 = ICC1
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = -IJH
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = -IJH
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & -IJH,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 1
+ ELSE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
+ & IVAL,IJH
+ CALL PHO_ABORT
+ ENDIF
+C
+ IC1 = ICB1
+ IC2 = 0
+C
+C gluon
+C****************************************************************
+C
+C gluon from valence quarks
+ ELSE
+ IF(IVAL.EQ.1) THEN
+C purely gluonic pomeron remnant
+ IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
+ IJSI1(INDXS) = 0
+ ELSE
+ P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
+ IJSI2(INDXS) = 0
+ ENDIF
+ IFL1 = 21
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(DT_RNDM(P2).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,ICB1,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 2
+C valence quark remnant
+ ELSE
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P2).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+ IUSED = 2
+ ENDIF
+C
+C gluon from sea quarks connected with valence quarks
+ ELSE IF(IVAL.EQ.0) THEN
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P3).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+ IF(IPAMDL(18).EQ.0) THEN
+C sea quark pair
+ CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
+ IF(ICC1.GT.0) THEN
+ IFL1 = ABS(IFL1)
+ IFL2 = -IFL1
+ ELSE
+ IFL1 = -ABS(IFL1)
+ IFL2 = -IFL1
+ ENDIF
+ IF(DT_RNDM(P4).LT.0.5D0) THEN
+ ICB1 = ICC2
+ CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ ICA1 = ICC1
+ CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+2)
+ P2 = PSOFT1(2,INDXS+2)
+ P3 = PSOFT1(3,INDXS+2)
+ P4 = PSOFT1(4,INDXS+2)
+ IJSI1(INDXS+2) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS+2)
+ P2 = PSOFT2(2,INDXS+2)
+ P3 = PSOFT2(3,INDXS+2)
+ P4 = PSOFT2(4,INDXS+2)
+ IJSI2(INDXS+2) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS+2,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+3)
+ P2 = PSOFT1(2,INDXS+3)
+ P3 = PSOFT1(3,INDXS+3)
+ P4 = PSOFT1(4,INDXS+3)
+ IJSI1(INDXS+3) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+3)
+ P2 = PSOFT2(2,INDXS+3)
+ P3 = PSOFT2(3,INDXS+3)
+ P4 = PSOFT2(4,INDXS+3)
+ IJSI2(INDXS+3) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+3,INDXH)
+
+ IUSED = 4
+ ELSE
+ IUSED = 2
+ ENDIF
+C
+C gluon from independent sea quarks
+ ELSE IF(IVAL.EQ.-1) THEN
+ IF(IPAMDL(18).EQ.0) THEN
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P1).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remainder of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,ICA2,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C remnant of sea
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS-1)
+ P2 = PSOFT1(2,INDXS-1)
+ P3 = PSOFT1(3,INDXS-1)
+ P4 = PSOFT1(4,INDXS-1)
+ IJSI1(INDXS-1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS-1)
+ P2 = PSOFT2(2,INDXS-1)
+ P3 = PSOFT2(3,INDXS-1)
+ P4 = PSOFT2(4,INDXS-1)
+ IJSI2(INDXS-1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,ICB2,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS-1,INDXH)
+
+ IUSED = 2
+ ELSE
+ CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_HARREM: no spectator added:(INDXS)',
+ & SIGN(INDXS,INDXH)
+ IUSED = 0
+ ENDIF
+C
+ ELSE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
+ & IVAL,IJH
+ CALL PHO_ABORT
+ ENDIF
+ IC1 = ICC1
+ IC2 = ICC2
+ ENDIF
+ END
+
+*$ CREATE PHO_HARDIR.FOR
+*COPY PHO_HARDIR
+CDECK ID>, PHO_HARDIR
+ SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
+ & IREJ)
+C**********************************************************************
+C
+C parton orientated formulation of direct scattering processes
+C
+C input:
+C
+C output: II particle combination (1..4)
+C IVAL1,2 0 no valence quarks engaged
+C 1 valence quarks engaged
+C MSPAR1,2 number of realized soft partons
+C MHPAR1,2 number of realized hard partons
+C IREJ 1 failure
+C 0 success
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4),PD1(-6:6)
+
+ PARAMETER ( TINY = 1.D-10 )
+
+ ITRY = 0
+ NTRY = 10
+ LSC1HD = 0
+ LSIDX(1) = 1
+
+C check phase space
+ IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
+ IFAIL(18) = IFAIL(18)+1
+ IREJ = 50
+ RETURN
+ ENDIF
+
+ AS = (PARMDL(160+II)/ECMP)**2
+ AH = (2.D0*PTWANT/ECMP)**2
+
+ ALNS = LOG(AS)
+ ALNH = LOG(AH)
+
+ XMAX = MAX(TINY,1.D0-AS)
+ Z1MAX = LOG(XMAX)
+ Z1DIF = Z1MAX-ALNH
+C
+C main loop to select hard and soft parton kinematics
+C -----------------------------------------------------
+ 120 CONTINUE
+ IREJ = 0
+ ITRY = ITRY+1
+ LSC1HD = LSC1HD+1
+ IF(ITRY.GT.1) THEN
+ IFAIL(17) = IFAIL(17)+1
+ IF(ITRY.GE.NTRY) THEN
+ IREJ = 1
+ GOTO 450
+ ENDIF
+ ENDIF
+ LINE = 0
+ LSCAHD = 0
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ MSPAR1 = 0
+ MSPAR2 = 0
+
+C select hard V,X
+ CALL PHO_HARSCA(1,II)
+ XSS1 = XSS1+X1
+ XSS2 = XSS2+X2
+C debug output
+ IF(IDEB(25).GE.20) THEN
+ WRITE(LO,'(1X,A,2E12.4,2I5)')
+ & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
+ & AS,XMAX,MSPR,ITRY
+ WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
+ & X1,X2,XSS1,XSS2
+ ENDIF
+
+ IF(MSPR.LE.11) THEN
+ IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
+ ELSE IF(MSPR.LE.13) THEN
+ IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
+ ENDIF
+
+C fill /POHSLT/
+ LSCAHD = 1
+ LSIDX(1) = 1
+ XHD(1,1) = X1
+ XHD(1,2) = X2
+ X0HD(1,1) = X1
+ X0HD(1,2) = X2
+ VHD(1) = V
+ ETAHD(1,1) = ETAC
+ ETAHD(1,2) = ETAD
+ PTHD(1) = PT
+ Q2SCA(1,1) = QQPD
+ Q2SCA(1,2) = QQPD
+ NPROHD(1) = MSPR
+ NBRAHD(1,1)= IDPDG1
+ NBRAHD(1,2)= IDPDG2
+ DO 45 I=1,4
+ PPH(I,1) = PHI1(I)
+ PPH(I,2) = PHI2(I)
+ PPH(4+I,1) = PHO1(I)
+ PPH(4+I,2) = PHO2(I)
+ 45 CONTINUE
+C valence quarks
+ IVAL1 = IV1
+ IVAL2 = IV2
+ PDFVA(1,1) = 0.D0
+ PDFVA(1,2) = 0.D0
+C parton flavours
+ IF(MSPR.LE.11) THEN
+ NINHD(1,1) = IDPDG1
+ NINHD(1,2) = IB
+ PDFVA(1,2) = PDF2(IB)
+ KHDIR = 1
+ ELSE IF(MSPR.LE.13) THEN
+ NINHD(1,1) = IA
+ PDFVA(1,1) = PDF1(IA)
+ NINHD(1,2) = IDPDG2
+ KHDIR = 2
+ ELSE
+ NINHD(1,1) = IDPDG1
+ NINHD(1,2) = IDPDG2
+ KHDIR = 3
+ ENDIF
+ N0INHD(1,1) = NINHD(1,1)
+ N0INHD(1,2) = NINHD(1,2)
+ N0IVAL(1,1) = IVAL1
+ N0IVAL(1,2) = IVAL2
+ NOUTHD(1,1) = IC
+ NOUTHD(1,2) = ID
+
+C reweight according to photon virtuality
+ IF(MSPR.NE.14) THEN
+ IF(IPAMDL(115).GE.1) THEN
+ WGX = 1.D0
+ IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
+ QQPD = Q2SCA(1,2)
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
+ WGX = 0.D0
+ ELSE
+ WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
+ WGX = PD1(IB)/PDFVA(1,2)
+ ENDIF
+ ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
+ & .AND.(IDPDG1.EQ.22)) THEN
+ QQPD = Q2SCA(1,1)
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
+ WGX = 0.D0
+ ELSE
+ WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
+ WGX = PD1(IA)/PDFVA(1,1)
+ ENDIF
+ ENDIF
+
+ IF(IDEB(25).GE.25)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
+ & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
+
+ IF(WGX.LT.DT_RNDM(WGX)) THEN
+ IREJ = 50
+ RETURN
+ ENDIF
+
+ IF(WGX.GT.1.01D0)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
+ & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
+
+ ENDIF
+ ENDIF
+
+C generate ISR
+ IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
+ IF(IPAMDL(109).EQ.1) THEN
+ Q2H = PARMDL(93)*PT**2
+ ELSE
+ Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
+ ENDIF
+ XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
+ XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
+ DO 42 J=1,4
+ P1(J) = PPH(4+J,1)
+ P2(J) = PPH(4+J,2)
+ 42 CONTINUE
+ CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
+ & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
+ & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
+ XSS1 = XSS1+XISR1-XHD(1,1)
+ XSS2 = XSS2+XISR2-XHD(1,2)
+ NINHD(1,1) = IFL1
+ NINHD(1,2) = IFL2
+ XHD(1,1) = XISR1
+ XHD(1,2) = XISR2
+ ELSE
+ IFL1 = NINHD(1,1)
+ IFL2 = NINHD(1,2)
+ ENDIF
+ NIVAL(1,1) = IVAL1
+ NIVAL(1,2) = IVAL2
+
+C add photon/hadron remnant
+
+C incoming gluon
+ IF(IFL2.EQ.0) THEN
+ XMAXX = 1.D0 - XSS2 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
+ IVAL2 = 1
+ MSPAR1 = 0
+ MSPAR2 = 2
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE IF(IFL1.EQ.0) THEN
+ XMAXX = 1.D0 - XSS1 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
+ IVAL1 = 1
+ MSPAR1 = 2
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+
+C incoming quark
+ ELSE IF(ABS(IFL2).LE.12) THEN
+ IF(IVAL2.EQ.1) THEN
+ XS2(1) = 1.D0 - XSS2
+ MSPAR1 = 0
+ MSPAR2 = 1
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE
+ XMAXX = 1.D0 - XSS2 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
+ MSPAR1 = 0
+ MSPAR2 = 3
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ENDIF
+ ELSE IF(ABS(IFL1).LE.12) THEN
+ IF(IVAL1.EQ.1) THEN
+ XS1(1) = 1.D0 - XSS1
+ MSPAR1 = 1
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE
+ XMAXX = 1.D0 - XSS1 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
+ MSPAR1 = 3
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ENDIF
+
+C double direct process
+ ELSE IF(MSPR.EQ.14) THEN
+ MSPAR1 = 0
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+
+C unknown process
+ ELSE
+ WRITE(LO,'(/1X,A,I3/)')
+ & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
+ GOTO 120
+ ENDIF
+
+C soft particle momenta
+ IF(MSPAR1.GT.0) THEN
+ DO 50 I=1,MSPAR1
+ PSOFT1(1,I) = 0.D0
+ PSOFT1(2,I) = 0.D0
+ PSOFT1(3,I) = XS1(I)*ECMP/2.D0
+ PSOFT1(4,I) = XS1(I)*ECMP/2.D0
+ 50 CONTINUE
+ ENDIF
+ IF(MSPAR2.GT.0) THEN
+ DO 55 I=1,MSPAR2
+ PSOFT2(1,I) = 0.D0
+ PSOFT2(2,I) = 0.D0
+ PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
+ PSOFT2(4,I) = XS2(I)*ECMP/2.D0
+ 55 CONTINUE
+ ENDIF
+C process counting
+ MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
+ KSOFT = MAX(MSPAR1,MSPAR2)
+ KHARD = MAX(MHPAR1,MHPAR2)
+C debug output
+ IF(IDEB(25).GE.10) THEN
+ WRITE(LO,'(/1X,A,2I3,3I5)')
+ & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
+ & IVAL1,IVAL2,MSPR,ITRY,NTRY
+ IF(MSPAR1.GT.0) THEN
+ WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
+ DO 105 I=1,MSPAR1
+ WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
+ 105 CONTINUE
+ ENDIF
+ IF(MSPAR2.GT.0) THEN
+ WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
+ DO 106 I=1,MSPAR2
+ WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
+ 106 CONTINUE
+ ENDIF
+ WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
+ WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
+ WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
+ WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
+ WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
+ WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
+ WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
+ WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
+ ENDIF
+ RETURN
+
+ 450 CONTINUE
+ IFAIL(16) = IFAIL(16)+1
+ IF(IDEB(25).GE.2) THEN
+ WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
+ WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
+ IF(IDEB(25).GE.5) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_POMSCA.FOR
+*COPY PHO_POMSCA
+CDECK ID>, PHO_POMSCA
+ SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
+ & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
+C**********************************************************************
+C
+C parton orientated formulation of soft and hard inelastic events
+C
+C
+C input: II particle combiantion (1..4)
+C MSPOM number of soft pomerons
+C MHPOM number of semihard pomerons
+C MSREG number of soft reggeons
+C
+C output: IVAL1,2 0 no valence quark engaged
+C otherwise: position of valence quark engaged
+C neg.number: gluon connected to valence quark
+C by color flow
+C MSPAR1,2 number of realized soft partons
+C MHPAR1,2 number of realized hard partons
+C IREJ 1 failure
+C 0 success
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (TINY = 1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4),PD1(-6:6)
+
+ IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
+
+ ITRY = 0
+ NTRY = 10
+ IREJ = 0
+ INMAX = 10
+ MHARD = MHPOM
+
+C phase space limitation (single hard valence-valence quark scattering)
+ IF(MHPOM.GT.0) THEN
+ Emin = 2.D0*PTWANT + 0.2D0
+ IF(ECMP.LT.Emin) THEN
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
+ & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ SAS = PARMDL(160+II)/ECMP
+ SAH = 2.D0*PTWANT/ECMP
+ AS = SAS**2
+ AH = SAH**2
+
+C save energy for leading particle effect
+ XMAXP1 = 1.D0
+ if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
+ XMAXP2 = 1.D0
+ if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
+
+C
+C main loop to select hard and soft parton kinematics
+C -----------------------------------------------------
+ IFAIL(31) = IFAIL(31)+MHARD
+ 20 CONTINUE
+ IREJ = 0
+ IHARD = 0
+ LSC1HD = 0
+ ITRY = ITRY+1
+ IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
+ IF(ITRY.GE.NTRY) THEN
+ IREJ = 1
+ GOTO 450
+ ENDIF
+ LINE = 0
+ LSCAHD = 0
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
+ XSS1 = MAX(0.D0,1.D0-XPSUB)
+ XSS2 = MAX(0.D0,1.D0-XTSUB)
+ ELSE
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ ENDIF
+ 22 continue
+
+C partons needed to construct soft/hard interactions
+ MSPAR1 = 2*MSPOM+MSREG+MHPOM
+ MSPAR2 = MSPAR1
+ MHPAR1 = MHPOM
+ MHPAR2 = MHPOM
+
+C number of strings
+ MSCHA = 2*MSPOM+MSREG
+ MHCHA = 2*MHPOM
+
+ KSOFT = MSCHA
+ KHARD = MHCHA
+
+C check actual phase space limit
+ XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
+ IF(XX.GE.1.D0) THEN
+ IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
+ & 'PHO_POMSCA: internal kin. rejection ',
+ & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
+ & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
+ if(MSPOM+MSREG+MHPOM.gt.1) then
+ if(MSREG.gt.0) then
+ MSREG = MSREG-1
+ else if(MSPOM.gt.0) THEN
+ MSPOM = MSPOM-1
+ else if(MHPOM.gt.1) then
+ MHPOM = MHPOM-1
+ endif
+ goto 22
+ endif
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
+ & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ ENDIF
+
+ XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
+ XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
+
+C very low energy phase space restriction
+ if(MHARD.gt.0) then
+ if((XMAXX1*XMAXX2.le.AH)) then
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
+ & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ endif
+ endif
+
+ AS = MAX(AS,PSOMIN/PCMP)
+ ALNS = LOG(AS)
+ ALNH = LOG(AH)
+ Z1MAX = LOG(XMAXX1)
+ Z2MAX = LOG(XMAXX2)
+ Z1DIF = Z1MAX+Z2MAX-ALNH
+ Z2DIF = Z1DIF
+ PTMAX = 0.D0
+C
+C select hard parton momenta
+C ------------------- begin of inner loop -------------------
+ IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
+
+ IF(MHARD.GT.MSCAHD) THEN
+ WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
+ & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ DO 11 NN=1,MHARD
+C
+C generate one resolved hard scattering
+C
+C high-pt option
+ IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
+ CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM)
+ XSCUT = HSig(9)
+ AHS = AH
+ ALNHS = ALNH
+ Z1DIFS = Z1DIF
+ Z2DIFS = Z2DIF
+ AH = (2.D0*PTWANT/ECMP)**2
+ ALNH = LOG(AH)
+ Z1DIF = Z1MAX+Z2MAX-ALNH
+ Z2DIF = Z1DIF
+ IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
+ & 'PHO_POMSCA: kin.rejection, high-pt option ',
+ & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
+ IREJ = 5
+ RETURN
+ ENDIF
+ CALL PHO_HARSCA(2,II)
+ CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM)
+ AH = AHS
+ ALNH = ALNHS
+ Z1DIF = Z1DIFS
+ Z2DIF = Z2DIFS
+ IPOWGC(4+II) = IPOWGC(4+II)+1
+ HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
+C minimum bias option
+ ELSE
+ CALL PHO_HARSCA(2,II)
+ ENDIF
+
+C fill /POHSLT/
+ LSIDX(NN) = NN
+ LSCAHD = NN
+ XHD(NN,1) = X1
+ XHD(NN,2) = X2
+ X0HD(NN,1) = X1
+ X0HD(NN,2) = X2
+ VHD(NN) = V
+ ETAHD(NN,1) = ETAC
+ ETAHD(NN,2) = ETAD
+ PTHD(NN) = PT
+ NPROHD(NN) = MSPR
+ Q2SCA(NN,1) = QQPD
+ Q2SCA(NN,2) = QQPD
+ PDFVA(NN,1) = PDF1(IA)
+ PDFVA(NN,2) = PDF2(IB)
+ NINHD(NN,1) = IA
+ NINHD(NN,2) = IB
+ N0INHD(NN,1) = IA
+ N0INHD(NN,2) = IB
+ NIVAL(NN,1) = IV1
+ NIVAL(NN,2) = IV2
+ N0IVAL(NN,1) = IV1
+ N0IVAL(NN,2) = IV2
+ NOUTHD(NN,1) = IC
+ NOUTHD(NN,2) = ID
+ NBRAHD(NN,1) = IDPDG1
+ NBRAHD(NN,2) = IDPDG2
+ I3 = 8*(NN-1)
+ I4 = 8*(NN-1)+4
+ DO 50 I=1,4
+ PPH(I3+I,1) = PHI1(I)
+ PPH(I3+I,2) = PHI2(I)
+ PPH(I4+I,1) = PHO1(I)
+ PPH(I4+I,2) = PHO2(I)
+ 50 CONTINUE
+
+ 11 CONTINUE
+
+C sort according to pt-hat
+ DO 12 NN=1,MHARD
+ PTMX = PTHD(LSIDX(NN))
+ IPTM = NN
+ DO 13 I=NN+1,MHARD
+ IF(PTHD(LSIDX(I)).GT.PTMX) THEN
+ IPTM = I
+ PTMX = PTHD(LSIDX(I))
+ ENDIF
+ 13 CONTINUE
+ IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
+ 12 CONTINUE
+ IPTM = LSIDX(1)
+
+C copy partons, generate ISR
+ DO 15 L=1,MHARD
+ NN = LSIDX(L)
+ XSSS1 = XSS1+XHD(NN,1)
+ XSSS2 = XSS2+XHD(NN,2)
+C debug output
+ IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
+ & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
+ & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
+C check phase space
+ IF( (XSSS1.GT.XMAXX1)
+ & .OR.(XSSS2.GT.XMAXX2)
+ & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
+ IF(IHARD.EQ.0) THEN
+ IF(ISWMDL(2).NE.1) GOTO 20
+ MHPOM = 0
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ GOTO 199
+ ENDIF
+
+C reweight according to photon virtuality
+ IF(IPAMDL(115).GE.1) THEN
+ QQPD = Q2SCA(NN,1)
+ WGX = 1.D0
+ IF(IDPDG1.EQ.22) THEN
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
+ WG1 = 0.D0
+ ELSE
+ WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
+ WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
+ ENDIF
+ WGX = WG1
+ ENDIF
+ QQPD = Q2SCA(NN,2)
+ IF(IDPDG2.EQ.22) THEN
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
+ WG1 = 0.D0
+ ELSE
+ WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
+ WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
+ ENDIF
+ WGX = WGX*WG1
+ ENDIF
+
+ IF(IDEB(24).GE.25)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
+ & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
+
+ IF(WGX.LT.DT_RNDM(WGX)) THEN
+ IF(L.EQ.1) THEN
+ IREJ = 50
+ RETURN
+ ELSE
+ GOTO 199
+ ENDIF
+ ENDIF
+
+ IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
+ & 'PHO_POMSCA: ',
+ & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
+
+ ENDIF
+
+C generate ISR
+ IF((ISWMDL(8).GE.2)
+ & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
+ IF(IPAMDL(109).EQ.1) THEN
+ Q2H = PARMDL(93)*PTHD(NN)**2
+ ELSE
+ Q2H = -PARMDL(93)*VHD(NN)
+ & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
+ ENDIF
+ XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
+ XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
+ I3 = 8*NN-4
+ DO 42 J=1,4
+ P1(J) = PPH(I3+J,1)
+ P2(J) = PPH(I3+J,2)
+ 42 CONTINUE
+ IF(IDEB(24).GE.10)
+ & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
+ & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
+ & L,NN,XHD(NN,1),XHD(NN,2),Q2H
+ J = NN
+ IF(L.EQ.1) J = -NN
+ CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
+ & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
+ & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
+ & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
+ XSSS1 = XSSS1+XISR1-XHD(NN,1)
+ XSSS2 = XSSS2+XISR2-XHD(NN,2)
+ NINHD(NN,1) = IFL1
+ NINHD(NN,2) = IFL2
+ XHD(NN,1) = XISR1
+ XHD(NN,2) = XISR2
+ ENDIF
+
+C check phase space
+ IF( (XSSS1.GT.XMAXX1)
+ & .OR.(XSSS2.GT.XMAXX2)
+ & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
+ IF(IHARD.EQ.0) THEN
+ IF(ISWMDL(2).NE.1) GOTO 20
+ MHPOM = 0
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ GOTO 199
+ ENDIF
+
+C leave energy for leading particle effect
+ IF((IHARD.GT.0).AND.
+ & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
+ GOTO 199
+ endif
+
+C hard scattering accepted
+ IHARD = IHARD+1
+ XSS1 = XSSS1
+ XSS2 = XSSS2
+ IFAIL(31) = IFAIL(31)-1
+
+ 15 CONTINUE
+
+C ------------------- end of inner (hard) loop -------------------
+ 199 CONTINUE
+
+ MHPOM = IHARD
+ MHPAR1 = IHARD
+ MHPAR2 = IHARD
+
+C count valences involved in hard scattering
+ IVAL1 = 0
+ IVAL2 = 0
+ DO 17 L=1,IHARD
+ NN = LSIDX(L)
+ IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
+ IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
+ 17 CONTINUE
+
+ IQUA1 = 0
+ IQUA2 = 0
+ IVGLU1 = 0
+ IVGLU2 = 0
+ DO 18 L=1,IHARD
+ NN = LSIDX(L)
+
+C photon, pomeron valences
+ IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ NIVAL(NN,1) = 1
+ IVAL1 = NN
+ ENDIF
+ ENDIF
+ IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ NIVAL(NN,2) = 1
+ IVAL2 = NN
+ ENDIF
+ ENDIF
+
+C total number of quarks
+ IF(NINHD(NN,1).NE.0) THEN
+ IQUA1 = IQUA1+1
+ ELSE IF(IVGLU1.EQ.0) THEN
+ IVGLU1 = NN
+ ENDIF
+ IF(NINHD(NN,2).NE.0) THEN
+ IQUA2 = IQUA2+1
+ ELSE IF(IVGLU2.EQ.0) THEN
+ IVGLU2 = NN
+ ENDIF
+ 18 CONTINUE
+
+C gluons emitted by valence quarks
+ VALPRO = 1.D0
+ IF(II.EQ.1) VALPRO = VALPRG(1)
+ IVQ1 = 1
+ IVG1 = 0
+ IVAL1 = MAX(IVAL1,0)
+ IF(IVAL1.EQ.0) THEN
+ IVQ1 = 0
+ IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
+ IVAL1 = -IVGLU1
+ IVG1 = 1
+ ENDIF
+ ENDIF
+ VALPRO = 1.D0
+ IF(II.EQ.1) VALPRO = VALPRG(2)
+ IVQ2 = 1
+ IVG2 = 0
+ IVAL2 = MAX(IVAL2,0)
+ IF(IVAL2.EQ.0) THEN
+ IVQ2 = 0
+ IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
+ IVAL2 = -IVGLU2
+ IVG2 = 1
+ ENDIF
+ ENDIF
+ MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
+C debug output
+ IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
+ & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
+ & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
+
+C select soft X values
+ 25 CONTINUE
+C number of soft/remnant quarks
+ IF(MSPOM.EQ.0) THEN
+ IF(IPAMDL(18).EQ.0) THEN
+ MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
+ MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
+ ELSE
+ MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
+ MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
+ ENDIF
+ ELSE
+ IF(IPAMDL(18).EQ.0) THEN
+ MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
+ MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
+ ELSE
+ MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
+ MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
+ ENDIF
+ ENDIF
+C debug output
+ IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
+ & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
+ & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
+
+ XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
+ XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
+ I1 = IVQ1
+ I2 = IVQ2
+ IF(IVAL1.LE.0) I1 = 0
+ IF(IVAL2.LE.0) I2 = 0
+ IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
+ MSDIFF = 2*MSPOM
+ ELSE
+ MSDIFF = 2*MAX(0,MSPOM-1)
+ ENDIF
+ MSG1 = MSPAR1
+ MSG2 = MSPAR2
+ MSM1 = MSPAR1-MSDIFF
+ MSM2 = MSPAR2-MSDIFF
+ XMAXH1 = MIN(XMAX1,PARMDL(44))
+ XMAXH2 = MIN(XMAX2,PARMDL(44))
+ CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
+ & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
+
+C correct for proper simulation of high pt tail
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
+ & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
+ & MSPOM,MHPOM,I1,I2
+ IF(MSPOM*MHPOM.GT.0) THEN
+ MSPOM = MSPOM-1
+ GOTO 25
+ ELSE IF(MSPOM.GT.1) THEN
+ MSPOM = MSPOM-1
+ GOTO 25
+ ELSE IF(MHPOM.GT.1) THEN
+ IHARD = IHARD-1
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
+ & .AND.(IPROCE.EQ.1)) THEN
+ XSS1 = MAX(0.D0,1.D0-XPSUB)
+ XSS2 = MAX(0.D0,1.D0-XTSUB)
+ ELSE
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ ENDIF
+ DO 103 K=1,IHARD
+ I = LSIDX(K)
+ XSS1 = XSS1+ XHD(I,1)
+ XSS2 = XSS2+ XHD(I,2)
+ 103 CONTINUE
+ GOTO 199
+ ENDIF
+ IREJ = 4
+ GOTO 450
+ ENDIF
+C accepted
+ MSPOM = MSPOM-(MSPAR1-MSG1)/2
+ MSPAR1 = MSG1
+ MSPAR2 = MSG2
+C ------------ kinematics sampled ---------------
+C debug output
+ IF(IDEB(24).GE.10) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_POMSCA: soft x values, ITRY',ITRY
+ DO 104 I=2,MAX(MSPAR1,MSPAR2)
+ WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
+ 104 CONTINUE
+ ENDIF
+ IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
+
+C end of loop
+ XS1(1) = 1.D0 - XSS1
+ XS2(1) = 1.D0 - XSS2
+
+C process counting
+ DO 30 N=1,LSCAHD
+ MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
+ 30 CONTINUE
+
+C soft particle momenta
+
+ IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
+ & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ DO 55 I=1,MSPAR1
+ PSOFT1(1,I) = 0.D0
+ PSOFT1(2,I) = 0.D0
+ PSOFT1(3,I) = XS1(I)*ECMP/2.D0
+ PSOFT1(4,I) = XS1(I)*ECMP/2.D0
+ 55 CONTINUE
+ DO 60 I=1,MSPAR2
+ PSOFT2(1,I) = 0.D0
+ PSOFT2(2,I) = 0.D0
+ PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
+ PSOFT2(4,I) = XS2(I)*ECMP/2.D0
+ 60 CONTINUE
+
+ KSOFT = MAX(MSPAR1,MSPAR2)
+ KHARD = MAX(MHPAR1,MHPAR2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+
+C debug output
+ IF(IDEB(24).GE.10) THEN
+ WRITE(LO,'(/1X,A,2I3,2I5)')
+ & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
+ & IVAL1,IVAL2,ITRY,NTRY
+ IF(MSPAR1+MSPAR2.GT.0) THEN
+ WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
+ XTMP1 = 0.D0
+ XTMP2 = 0.D0
+ DO 105 I=1,MAX(MSPAR1,MSPAR2)
+ IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
+ XTMP1 = XTMP1+XS1(I)
+ XTMP2 = XTMP2+XS2(I)
+ ELSE IF(I.LE.MSPAR1) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
+ XTMP1 = XTMP1+XS1(I)
+ ELSE IF(I.LE.MSPAR2) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
+ XTMP2 = XTMP2+XS2(I)
+ ENDIF
+ 105 CONTINUE
+ WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
+ ENDIF
+ IF(MHPAR1.GT.0) THEN
+ WRITE(LO,'(5X,A)')
+ & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
+ DO 107 K=1,MHPAR1
+ I = LSIDX(K)
+ WRITE(LO,'(5X,3I3,4E12.3,2I3)')
+ & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
+ & NINHD(I,1),NINHD(I,2)
+ XTMP1 = XTMP1+XHD(I,1)
+ XTMP2 = XTMP2+XHD(I,2)
+ 107 CONTINUE
+ WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
+ WRITE(LO,'(5X,A)') 'hard momenta particle1:'
+ DO 108 K=1,MHPAR1
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
+ & NOUTHD(I,1)
+ 108 CONTINUE
+ WRITE(LO,'(5X,A)') 'hard momenta particle2:'
+ DO 110 K=1,MHPAR2
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
+ & NOUTHD(I,2)
+ 110 CONTINUE
+ ENDIF
+ ENDIF
+ RETURN
+
+C event rejected, print debug information
+ 450 CONTINUE
+ IFAIL(4) = IFAIL(4)+1
+ IF(IDEB(24).GE.2) THEN
+ WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
+ & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
+ & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
+ WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
+ IF(IDEB(24).GE.5) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARX12.FOR
+*COPY PHO_HARX12
+CDECK ID>, PHO_HARX12
+ SUBROUTINE PHO_HARX12
+C**********************************************************************
+C
+C selection of x1 and x2 according to 1/x1*1/x2
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+10 CONTINUE
+ Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
+ Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
+ IF ( (Z1+Z2).LT.ALNH ) GOTO 10
+ X1 = EXP(Z1)
+ X2 = EXP(Z2)
+ AXX = AH/(X1*X2)
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+
+ END
+
+*$ CREATE PHO_HARDX1.FOR
+*COPY PHO_HARDX1
+CDECK ID>, PHO_HARDX1
+ SUBROUTINE PHO_HARDX1
+C**********************************************************************
+C
+C selection of x1 according to 1/x1
+C ( x2 = 1 )
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
+ X2 = 1.D0
+ X1 = EXP(Z1)
+ AXX = AH/X1
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+
+ END
+
+*$ CREATE PHO_HARKIN.FOR
+*COPY PHO_HARKIN
+CDECK ID>, PHO_HARKIN
+ SUBROUTINE PHO_HARKIN(IREJ)
+C***********************************************************************
+C
+C selection of kinematic variables
+C (resolved and direct processes)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C internal cross check information on hard scattering limits
+ DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
+ COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
+
+ PARAMETER ( Max_pro_2 = 16 )
+ DIMENSION RM(-1:Max_pro_2)
+ DATA RM / 3.31D0, 0.0D0,
+ & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
+ & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
+ & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
+ & 1.0D0 /
+
+ IREJ = 0
+ M = MSPR
+
+C------------- resolved processes -----------
+ IF ( M.EQ.1 ) THEN
+10 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
+20 CALL PHO_HARX12
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.3 ) THEN
+30 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
+ ELSEIF ( M.EQ.5 ) THEN
+50 CALL PHO_HARX12
+ V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
+ ELSEIF ( M.EQ.6 ) THEN
+60 CALL PHO_HARX12
+ V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(U*U+V*V)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
+ ELSEIF ( M.EQ.7 ) THEN
+70 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
+ & -(4.D0/27.D0)*V/U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.8 ) THEN
+80 CALL PHO_HARX12
+ V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(1.D0+U*U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
+ ELSEIF ( M.EQ.-1 ) THEN
+90 CALL PHO_HARX12
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
+C------------- direct / single-resolved processes -----------
+ ELSEIF ( M.EQ.10 ) THEN
+100 CALL PHO_HARDX1
+ WL = LOG(AXX/(1.D0+W)**2)
+ U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
+ R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
+ V =-1.D0-U
+ X2 = X1
+ X1 = 1.D0
+ ELSEIF ( M.EQ.11) THEN
+110 CALL PHO_HARDX1
+ WL = LOG(W1)
+ U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ V =-1.D0-U
+ R = (U*U+V*V)/V*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ X2 = X1
+ X1 = 1.D0
+ ELSEIF ( M.EQ.12 ) THEN
+120 CALL PHO_HARDX1
+ WL = LOG(AXX/(1.D0+W)**2)
+ V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
+ R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
+ ELSEIF ( M.EQ.13) THEN
+130 CALL PHO_HARDX1
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (U*U+V*V)/U*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+C------------- (double) direct process -----------
+ ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
+ X1 = 1.D0
+ X2 = 1.D0
+ AXX= AH
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+ WL = LOG(W1)
+ 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = -(U*U+V*V)/U
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+C---------------------------------------------
+ ELSE
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+ V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
+ U = -1.D0-V
+ U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
+ PT = SQRT(U*V*X1*X2)*ECMP
+ ETAC = 0.5D0*LOG((U*X1)/(V*X2))
+ ETAD = 0.5D0*LOG((V*X1)/(U*X2))
+
+***************************************************************
+ MM = M
+ IF(M.EQ.-1) MM = 3
+ ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
+ ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
+ ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
+ ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
+ XXMI(1,MM) = MIN(XXMI(1,MM),X1)
+ XXMA(1,MM) = MAX(XXMA(1,MM),X1)
+ XXMI(2,MM) = MIN(XXMI(2,MM),X2)
+ XXMA(2,MM) = MAX(XXMA(2,MM),X2)
+***************************************************************
+
+ IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
+ & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
+
+ END
+
+*$ CREATE PHO_HARWGH.FOR
+*COPY PHO_HARWGH
+CDECK ID>, PHO_HARWGH
+ SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
+C***********************************************************************
+C
+C calculate product of PDFs and coupling constants
+C according to selected MSPR (process type)
+C
+C input: /POCKIN/
+C
+C output: PDS resulting from PDFs alone
+C FDISTR complete weight function
+C PDA,PDB fields containing the PDFs
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION PDA(-6:6),PDB(-6:6)
+
+ FDISTR = 0.D0
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
+ ENDIF
+C coupling constants, PDFs
+ IF(MSPR.LT.9) THEN
+ ALPHA1 = PHO_ALPHAS(QQAL,3)
+ ALPHA2 = ALPHA1
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
+ PDS = PDA(0)*PDB(0)
+ ELSE
+ S2 = 0.D0
+ S3 = 0.D0
+ S4 = 0.D0
+ S5 = 0.D0
+ DO 10 I=1,NF
+ S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ S4 = S4+PDA(I)+PDA(-I)
+ S5 = S5+PDB(I)+PDB(-I)
+ 10 CONTINUE
+ IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
+ PDS = S2
+ ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
+ PDS = PDA(0)*S5+PDB(0)*S4
+ ELSE IF(MSPR.EQ.7) THEN
+ PDS = S3
+ ELSE IF(MSPR.EQ.8) THEN
+ PDS = S4*S5-(S2+S3)
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.LT.12) THEN
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ S4 = 0.D0
+ S6 = 0.D0
+ DO 15 I=1,NF
+ S4 = S4+PDB(I)+PDB(-I)
+C charge counting
+* IF(MOD(I,2).EQ.0) THEN
+* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
+* ELSE
+* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
+* ENDIF
+ S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
+ 15 CONTINUE
+ IF(MSPR.EQ.10) THEN
+ IF(IDPDG1.EQ.990) THEN
+ PDS = S4
+ ELSE
+ PDS = S6
+ ENDIF
+ ELSE
+ PDS = PDB(0)
+ ENDIF
+ ELSE IF(MSPR.LT.14) THEN
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ S4 = 0.D0
+ S6 = 0.D0
+ DO 20 I=1,NF
+ S4 = S4+PDA(I)+PDA(-I)
+C charge counting
+* IF(MOD(I,2).EQ.0) THEN
+* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
+* ELSE
+* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
+* ENDIF
+ S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
+ 20 CONTINUE
+ IF(MSPR.EQ.12) THEN
+ IF(IDPDG2.EQ.990) THEN
+ PDS = S4
+ ELSE
+ PDS = S6
+ ENDIF
+ ELSE
+ PDS = PDA(0)
+ ENDIF
+ ELSE IF(MSPR.EQ.14) THEN
+ SSR = X1*X2*ECMP*ECMP
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(SSR)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(SSR)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ PDS = 1.D0
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+C complete weight
+ FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
+
+C debug output
+ IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
+ & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
+ & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
+
+ END
+
+*$ CREATE PHO_HARSCA.FOR
+*COPY PHO_HARSCA
+CDECK ID>, PHO_HARSCA
+ SUBROUTINE PHO_HARSCA(IMODE,IP)
+C***********************************************************************
+C
+C PHO_HARSCA determines the type of hard subprocess, the partons
+C taking part in this subprocess and the kinematic variables
+C
+C input: IMODE 1 direct processes
+C 2 resolved processes
+C -1 initialization
+C -2 output of statistics
+C IP 1-4 particle combination (hadron/photon)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER( EPS = 1.D-10,
+ & DEPS = 1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ 111 CONTINUE
+
+C resolved processes
+ IF(IMODE.EQ.2) THEN
+
+ MH_pro_on(0,IP) = 0
+ HWgx(9) = 0.D0
+ DO 15 M=-1,8
+ IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
+ 15 CONTINUE
+ IF(HWgx(9).LT.DEPS) THEN
+ WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
+ & 'no resolved process possible for IP',IP,HWgx(9)
+ CALL PHO_ABORT
+ ENDIF
+C
+C ----------------------------------------------I
+C begin of iteration loop (resolved processes) I
+C I
+ IREJSC = 0
+ 10 CONTINUE
+ IREJSC = IREJSC+1
+ IF(IREJSC.GT.1000) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
+ CALL PHO_ABORT
+ ENDIF
+
+C find subprocess
+ B = DT_RNDM(X1)*HWgx(9)
+ MSPR =-2
+ SUM = 0.D0
+ 20 MSPR = MSPR+1
+ IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
+ IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
+
+ IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
+ & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
+
+C find kin. variables X1,X2 and V
+ CALL PHO_HARKIN(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(29) = IFAIL(29)+1
+ GOTO 10
+ ENDIF
+C calculate remaining distribution
+ CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
+C actualize counter for cross-section calculation
+ if(F.LE.1.D-15) then
+ F = 0.D0
+ goto 10
+ endif
+* XSECT(5,MSPR) = XSECT(5,MSPR)+F
+* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
+ MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
+C check F against FMAX
+ WEIGHT = F/(HWgx(MSPR)+DEPS)
+ IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
+C-------------------------------------------------------------------
+ IF(WEIGHT.GT.1.D0) THEN
+ WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
+ 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
+ & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
+ WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
+ & ECMP,PTWANT,AS,AH,PT
+ WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
+ & ETAC,ETAD,X1,X2,V
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C-------------------------------------------------------------------
+C I
+C end of iteration loop (resolved processes) I
+C --------------------------------------------I
+C
+C*********************************************************************
+C
+C direct processes
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+C single-resolved processes kinematically forbidden
+ if(Z1DIF.lt.0.D0) then
+ HWgx(10) = 0.D0
+ HWgx(11) = 0.D0
+ HWgx(12) = 0.D0
+ HWgx(13) = 0.D0
+ endif
+
+ HWgx(15) = 0.D0
+ if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
+ DO M= 10,14
+ IF(MH_pro_on(M,IP).EQ.1) then
+ if((M.eq.10).or.(M.eq.11)) then
+ fac = FSUH(1)*FSUP(2)
+ else if((M.eq.12).or.(M.eq.13)) then
+ fac = FSUP(1)*FSUH(2)
+ else
+ fac = FSUH(1)*FSUH(2)
+ endif
+ HWgx(15) = HWgx(15)+HWgx(M)*fac
+ endif
+ ENDDO
+ else
+ DO M= 10,14
+ IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
+ ENDDO
+ endif
+ IF(HWgx(15).LT.DEPS) THEN
+ WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
+ & 'no direct/single-resolved process possible (IP)',IP
+ CALL PHO_ABORT
+ ENDIF
+C
+C ----------------------------------------------I
+C begin of iteration loop (direct processes) I
+C I
+ IREJSC = 0
+ 100 CONTINUE
+ IREJSC = IREJSC+1
+ IF(IREJSC.GT.1000) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
+ CALL PHO_ABORT
+ ENDIF
+
+C find subprocess
+ B = DT_RNDM(X1)*HWgx(15)
+ MSPR = 9
+ SUM = 0.D0
+ if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
+ 150 continue
+ MSPR = MSPR+1
+ IF(MH_pro_on(MSPR,IP).EQ.1) then
+ if((MSPR.eq.10).or.(MSPR.eq.11)) then
+ fac = FSUH(1)*FSUP(2)
+ else if((MSPR.eq.12).or.(MSPR.eq.13)) then
+ fac = FSUP(1)*FSUH(2)
+ else
+ fac = FSUH(1)*FSUH(2)
+ endif
+ SUM = SUM+HWgx(MSPR)*fac
+ endif
+ IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
+ else
+ 200 continue
+ MSPR = MSPR+1
+ IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
+ IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
+ endif
+
+ IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
+ & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
+
+C find kin. variables X1,X2 and V
+ CALL PHO_HARKIN(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(28) = IFAIL(28)+1
+ GOTO 100
+ ENDIF
+
+C calculate remaining distribution
+ CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
+
+C counter for cross-section calculation
+ if(F.LE.1.D-15) then
+ F=0.D0
+ goto 100
+ endif
+* XSECT(5,MSPR) = XSECT(5,MSPR)+F
+* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
+ MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
+C check F against FMAX
+ WEIGHT = F/(HWgx(MSPR)+DEPS)
+ IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
+C-------------------------------------------------------------------
+ IF(WEIGHT.GT.1.D0) THEN
+ WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
+ 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
+ & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
+ WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
+ & ECMP,PTWANT,AS,AH,PT
+ WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
+ & ETAC,ETAD,X1,X2,V
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C-------------------------------------------------------------------
+C I
+C end of iteration loop (direct processes) I
+C --------------------------------------------I
+
+ ELSE IF(IMODE.EQ.-1) THEN
+
+C initialize cross section calculations
+
+ DO 40 M=-1,Max_pro_2
+* DO 30 I=5,6
+* XSECT(I,M) = 0.D0
+*30 CONTINUE
+C reset counters
+ DO 35 J=1,4
+ MH_tried(M,J) = 0
+ MH_acc_1(M,J) = 0
+ MH_acc_2(M,J) = 0
+ 35 CONTINUE
+ 40 CONTINUE
+ IF(IDEB(78).GE.0) THEN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_HARSCA: activated hard processes',
+ & '------------------------------------'
+ WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
+ DO 42 M=1,Max_pro_2
+ WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
+ & (MH_pro_on(M,J),J=1,4)
+ 42 CONTINUE
+ ENDIF
+ RETURN
+
+ ELSE IF(IMODE.EQ.-2) THEN
+
+C calculation of process statistics
+
+ do K=1,4
+
+ MH_tried(0,K) = 0
+ MH_acc_1(0,K) = 0
+ MH_acc_2(0,K) = 0
+ MH_tried(9,K) = 0
+ MH_acc_1(9,K) = 0
+ MH_acc_2(9,K) = 0
+ MH_tried(15,K) = 0
+ MH_acc_1(15,K) = 0
+ MH_acc_2(15,K) = 0
+
+ MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
+ MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
+ MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
+
+ do M=1,8
+ MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
+ MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
+ MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
+ enddo
+ do M=10,14
+ MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
+ MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
+ MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
+ enddo
+ MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
+ MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
+ MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
+ enddo
+
+ IF(IDEB(78).GE.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_HARSCA: internal rejection statistics',
+ & '-----------------------------------------'
+ do K=1,4
+ IF(MH_tried(0,K).GT.0) THEN
+ WRITE(LO,'(5X,A,I3)')
+ & 'process (sampled/accepted) for IP:',K
+ do M=0,Max_pro_2
+ WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
+ & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
+ & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
+ enddo
+ ENDIF
+ enddo
+ ENDIF
+ RETURN
+
+ ELSE
+ WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
+ & 'unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C the event is accepted now
+C actualize counter for accepted events
+ MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
+ IF(MSPR.EQ.-1) MSPR = 3
+C
+C find flavor of initial partons
+C
+ SUM = 0.D0
+ SCHECK = DT_RNDM(SUM)*PDS-EPS
+ IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
+ IA = 0
+ IB = 0
+ ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
+ DO 610 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 610
+ SUM = SUM+PDF1(IA)*PDF2(-IA)
+ IF ( SUM.GE.SCHECK ) GOTO 620
+ 610 CONTINUE
+ 620 IB =-IA
+ ELSEIF ( MSPR.EQ.3 ) THEN
+ IB = 0
+ DO 630 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 630
+ SUM = SUM+PDF1(0)*PDF2(IA)
+ IF ( SUM.GE.SCHECK ) GOTO 640
+ SUM = SUM+PDF1(IA)*PDF2(0)
+ IF ( SUM.GE.SCHECK ) GOTO 650
+ 630 CONTINUE
+ 640 IB = IA
+ IA = 0
+ 650 CONTINUE
+ ELSEIF ( MSPR.EQ.7 ) THEN
+ DO 660 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 660
+ SUM = SUM+PDF1(IA)*PDF2(IA)
+ IF ( SUM.GE.SCHECK ) GOTO 670
+ 660 CONTINUE
+ 670 IB = IA
+ ELSEIF ( MSPR.EQ.8 ) THEN
+ DO 690 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 690
+ DO 680 IB=-NF,NF
+ IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
+ SUM = SUM+PDF1(IA)*PDF2(IB)
+ IF ( SUM.GE.SCHECK ) GOTO 700
+ 680 CONTINUE
+ 690 CONTINUE
+ 700 CONTINUE
+ ELSEIF ( MSPR.EQ.10 ) THEN
+ IA = 0
+ DO 710 IB=-NF,NF
+ IF ( IB.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IB),2).EQ.0) THEN
+* SUM = SUM+PDF2(IB)*4.D0/9.D0
+* ELSE
+* SUM = SUM+PDF2(IB)*1.D0/9.D0
+* ENDIF
+ SUM = SUM+PDF2(IB)*Q_ch2(IB)
+ ELSE
+ SUM = SUM+PDF2(IB)
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 720
+ ENDIF
+ 710 CONTINUE
+ 720 CONTINUE
+ ELSEIF ( MSPR.EQ.12 ) THEN
+ IB = 0
+ DO 810 IA=-NF,NF
+ IF ( IA.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IA),2).EQ.0) THEN
+* SUM = SUM+PDF1(IA)*4.D0/9.D0
+* ELSE
+* SUM = SUM+PDF1(IA)*1.D0/9.D0
+* ENDIF
+ SUM = SUM+PDF1(IA)*Q_ch2(IA)
+ ELSE
+ SUM = SUM+PDF1(IA)
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 820
+ ENDIF
+ 810 CONTINUE
+ 820 CONTINUE
+ ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
+ IA = 0
+ IB = 0
+ ENDIF
+C final check
+ IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
+ write(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
+ write(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
+ GOTO 111
+ ENDIF
+C
+C find flavour of final partons
+C
+ IC = IA
+ ID = IB
+ IF ( MSPR.EQ.2 ) THEN
+ IC = 0
+ ID = 0
+ ELSEIF ( MSPR.EQ.4 ) THEN
+ IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
+ IF ( IC.GT.NF ) IC = NF-IC
+ ID =-IC
+ ELSEIF ( MSPR.EQ.6 ) THEN
+ IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
+ IF ( IC.GT.NF-1 ) IC = NF-1-IC
+ IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
+ ID =-IC
+ ELSEIF ( MSPR.EQ.11) THEN
+ SUM = 0.D0
+ DO 730 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ ENDIF
+ 730 CONTINUE
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 740 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 750
+ ENDIF
+ 740 CONTINUE
+ 750 CONTINUE
+ ID = -IC
+ ELSEIF ( MSPR.EQ.12) THEN
+ IC = 0
+ ID = IA
+ ELSEIF ( MSPR.EQ.13) THEN
+ SUM = 0.D0
+ DO 830 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ ENDIF
+ 830 CONTINUE
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 840 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 850
+ ENDIF
+ 840 CONTINUE
+ 850 CONTINUE
+ ID = -IC
+ ELSEIF ( MSPR.EQ.14) THEN
+ SUM = 0.D0
+ DO 930 IC=1,NF
+ FAC1 = 1.D0
+ FAC2 = 1.D0
+ IF(MOD(ABS(IC),2).EQ.0) THEN
+ IF(IDPDG1.EQ.22) FAC1 = 4.D0
+ IF(IDPDG2.EQ.22) FAC2 = 4.D0
+ ENDIF
+ SUM = SUM + FAC1*FAC2
+ 930 CONTINUE
+ IF(IPAMDL(64).NE.0) THEN
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
+ ENDIF
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 940 IC=1,NF
+ FAC1 = 1.D0
+ FAC2 = 1.D0
+ IF(MOD(ABS(IC),2).EQ.0) THEN
+ IF(IDPDG1.EQ.22) FAC1 = 4.D0
+ IF(IDPDG2.EQ.22) FAC2 = 4.D0
+ ENDIF
+ SUM = SUM + FAC1*FAC2
+ IF ( SUM.GE.SCHECK ) GOTO 950
+ 940 CONTINUE
+ IC = 15
+ 950 CONTINUE
+ ID = -IC
+ IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
+ ENDIF
+ if(IC.eq.0) then
+ XM3 = 0.D0
+ else
+ XM3 = PHO_PMASS(IC,3)
+ endif
+ if(ID.eq.0) then
+ XM4 = 0.D0
+ else
+ XM4 = PHO_PMASS(ID,3)
+ endif
+ IF(ABS(IC).EQ.15) GOTO 955
+
+C valence quarks involved?
+ IV1 = 0
+ IF(IA.NE.0) THEN
+ IF(IDPDG1.EQ.22) THEN
+ CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
+ IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
+ ELSE
+ IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
+ ENDIF
+ ENDIF
+ IV2 = 0
+ IF(IB.NE.0) THEN
+ IF(IDPDG2.EQ.22) THEN
+ CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
+ IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
+ ELSE
+ IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
+ ENDIF
+ ENDIF
+C
+C fill event record
+C
+ 955 CONTINUE
+ CALL PHO_SFECFE(SINPHI,COSPHI)
+ ECM2 = ECMP/2.D0
+C incoming partons
+ PHI1(1) = 0.D0
+ PHI1(2) = 0.D0
+ PHI1(3) = ECM2*X1
+ PHI1(4) = PHI1(3)
+ PHI1(5) = 0.D0
+ PHI2(1) = 0.D0
+ PHI2(2) = 0.D0
+ PHI2(3) = -ECM2*X2
+ PHI2(4) = -PHI2(3)
+ PHI2(5) = 0.D0
+C outgoing partons
+ PHO1(1) = PT*COSPHI
+ PHO1(2) = PT*SINPHI
+ PHO1(3) = -ECM2*(U*X1-V*X2)
+ PHO1(4) = -ECM2*(U*X1+V*X2)
+ PHO1(5) = XM3
+ PHO2(1) = -PHO1(1)
+ PHO2(2) = -PHO1(2)
+ PHO2(3) = -ECM2*(V*X1-U*X2)
+ PHO2(4) = -ECM2*(V*X1+U*X2)
+ PHO2(5) = XM4
+
+C convert to mass shell
+ CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
+ & PT,XM3,XM4
+ GOTO 111
+ ENDIF
+ PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
+
+C debug output
+ IF(IDEB(78).GE.20) THEN
+ SHAT = X1*X2*ECMP*ECMP
+ WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
+ & MSPR,IA,IB,IC,ID
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARFAC.FOR
+*COPY PHO_HARFAC
+CDECK ID>, PHO_HARFAC
+ SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
+C*********************************************************************
+C
+C initialization: find scaling factors and maxima of remaining
+C weights
+C
+C input: PTCUT transverse momentum cutoff
+C ECMI cms energy
+C
+C output: Hfac(-1:Max_pro_2) field for sampling hard processes
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( MXABWT = 96 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+ DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
+ DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
+ & F124(-1:Max_pro_2)
+ DATA F124 / 1.D0,0.D0,
+ & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
+ & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
+
+ SS = ECMI*ECMI
+ AH = (2.D0*PTCUT/ECMI)**2
+ ALN = LOG(AH)
+ HLN = LOG(0.5D0)
+ NPOINT = NGAUIN
+ CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
+ DO 10 M=-1,Max_pro_2
+ S1(M) = 0.D0
+10 CONTINUE
+
+C resolved processes
+ DO 80 I1=1,NPOINT
+ Z1 = ABSZ(I1)
+ X1 = EXP(ALN*Z1)
+ DO 20 M=-1,9
+ S2(M) = 0.D0
+20 CONTINUE
+
+ DO 60 I2=1,NPOINT
+ Z2 = (1.D0-Z1)*ABSZ(I2)
+ X2 = EXP(ALN*Z2)
+ FAXX = AH/(X1*X2)
+ W = SQRT(1.D0-FAXX)
+ W1 = FAXX/(1.+W)
+ WLOG = LOG(W1)
+ FWW = FAXX*WLOG/W
+ DO 30 M=-1,9
+ S(M) = 0.D0
+30 CONTINUE
+
+ DO 40 I=1,NPOINT
+ Z = ABSZ(I)
+ VA =-0.5D0*W1/(W1+Z*W)
+ UA =-1.D0-VA
+ VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
+ UB =-1.D0-VB
+ VC =-EXP(HLN+Z*WLOG)
+ UC =-1.D0-VC
+ VE =-0.5D0*(1.D0+W)+Z*W
+ UE =-1.D0-VE
+ S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
+ & WEIG(I)
+ S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
+ & WEIG(I)
+ S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
+ S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
+ & (8./27.)*UA*UA*VA)*WEIG(I)
+ S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
+ S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
+ & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
+ S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
+ S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
+40 CONTINUE
+ S(4) = S(2)*(9./32.)
+ DO 50 M=-1,8
+ S2(M) = S2(M)+S(M)*WEIG(I2)*W
+50 CONTINUE
+60 CONTINUE
+ DO 70 M=-1,8
+ S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
+70 CONTINUE
+80 CONTINUE
+ S1(4) = S1(4)*NF
+ S1(6) = S1(6)*MAX(0,NF-1)
+C
+C direct processes
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
+ & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ DO 180 I1=1,NPOINT
+ Z2 = ABSZ(I1)
+ X2 = EXP(ALN*Z2)
+ FAXX = AH/X2
+ W = SQRT(1.D0-FAXX)
+ W1 = FAXX/(1.D0+W)
+ WLOG = LOG(W1)
+ WL = LOG(FAXX/(1.D0+W)**2)
+ FWW1 = FAXX*WL/ALN
+ FWW2 = FAXX*WLOG/ALN
+ DO 130 M=10,12
+ S(M) = 0.D0
+ 130 CONTINUE
+C
+ DO 140 I=1,NPOINT
+ Z = ABSZ(I)
+ UA =-(1.D0+W)/2.D0*EXP(Z*WL)
+ VA =-1.D0-UA
+ VB =-EXP(HLN+Z*WLOG)
+ UB =-1.D0-VB
+ S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
+ S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
+ 140 CONTINUE
+ DO 170 M=10,11
+ S1(M) = S1(M)+S(M)*WEIG(I1)
+ 170 CONTINUE
+ 180 CONTINUE
+ S1(12) = S1(10)
+ S1(13) = S1(11)
+C quark charges fractions
+ IF(IDPDG1.EQ.22) THEN
+ CHRNF = 0.D0
+ DO 100 I=1,NF
+ CHRNF = CHRNF + Q_ch2(I)
+ 100 CONTINUE
+ S1(11) = S1(11)*CHRNF
+ ELSE IF(IDPDG1.EQ.990) THEN
+ S1(11) = S1(11)*NF
+ ELSE
+ S1(11) = 0.D0
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ CHRNF = 0.D0
+ DO 200 I=1,NF
+ CHRNF = CHRNF + Q_ch2(I)
+ 200 CONTINUE
+ S1(13) = S1(13)*CHRNF
+ ELSE IF(IDPDG2.EQ.990) THEN
+ S1(13) = S1(13)*NF
+ ELSE
+ S1(13) = 0.D0
+ ENDIF
+ ENDIF
+C
+C global factors
+ FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
+ DO 90 M=-1,Max_pro_2
+ Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
+90 CONTINUE
+C
+C double direct process
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FAC = 0.D0
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+ F1 = Q_ch2(I)
+ ELSE
+ F1 = 1.D0
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ F2 = Q_ch2(I)
+ ELSE
+ F2 = 1.D0
+ ENDIF
+ FAC = FAC+F1*F2*3.D0
+ 300 CONTINUE
+ ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
+ Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
+ & *GEV2MB*FAC
+ ENDIF
+ END
+
+*$ CREATE PHO_HARWGX.FOR
+*COPY PHO_HARWGX
+CDECK ID>, PHO_HARWGX
+ SUBROUTINE PHO_HARWGX(PTCUT,ECM)
+C**********************************************************************
+C
+C find maximum of remaining weight for MC sampling
+C
+C input: PTCUT transverse momentum cutoff
+C ECM cms energy
+C
+C output: HWgx(-1:Max_pro_2) field for sampling hard processes
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( NKM = 10 )
+ PARAMETER ( TINY = 1.D-20 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+
+ DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
+ & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
+ DIMENSION IFTAB(-1:Max_pro_2)
+ DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
+
+C initial settings
+ AH = (2.D0*PTCUT/ECM)**2
+ ALNH = LOG(AH)
+ FF(0) = 0.D0
+ DO 22 I=1,NKM
+ FF(I) = 0.D0
+ XM1(I) = 0.D0
+ XM2(I) = 0.D0
+ PTM(I) = 0.D0
+ ZMX(1,I) = 0.D0
+ ZMX(2,I) = 0.D0
+ ZMX(3,I) = 0.D0
+ DMX(1,I) = 0.D0
+ DMX(2,I) = 0.D0
+ DMX(3,I) = 0.D0
+ IMX(I) = 0
+ IPO(I) = 0
+ 22 CONTINUE
+
+ NKML = 10
+ DO 40 NKON=1,NKML
+
+ DO 50 IST=1,3
+C start configuration
+ IF(IST.EQ.1) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.5
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.2) THEN
+ Z(1) = 0.999D0
+ Z(2) = 0.5
+ Z(3) = 0.0
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.3) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.1
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.4) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.9
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ENDIF
+ IT = 0
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
+C process possible?
+ IF(F2.LE.0.D0) GOTO 35
+
+ 10 CONTINUE
+ IT = IT+1
+ FOLD = F2
+ DO 30 I=1,3
+ D(I) = D(I)/5.D0
+ Z(I) = Z(I)+D(I)
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
+ IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
+ IF ( F2.GT.F3 ) D(I) =-D(I)
+ 20 CONTINUE
+ F1 = MIN(F2,F3)
+ F2 = MAX(F2,F3)
+ Z(I) = Z(I)+D(I)
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
+ IF ( F3.GT.F2 ) GOTO 20
+ ZZ = Z(I)-D(I)
+ Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
+ IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
+ & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
+ IF ( F1.LE.F2 ) Z(I) = ZZ
+ F2 = MAX(F1,F2)
+ 30 CONTINUE
+ IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
+
+ IF(F2.GT.FF(NKON)) THEN
+ FF(NKON) = MAX(F2,0.D0)
+ XM1(NKON) = X1
+ XM2(NKON) = X2
+ PTM(NKON) = PT
+ ZMX(1,NKON) = Z(1)
+ ZMX(2,NKON) = Z(2)
+ ZMX(3,NKON) = Z(3)
+ DMX(1,NKON) = D(1)
+ DMX(2,NKON) = D(2)
+ DMX(3,NKON) = D(3)
+ IMX(NKON) = IT
+ IPO(NKON) = IST
+ ENDIF
+C
+ 50 CONTINUE
+ 35 CONTINUE
+ 40 CONTINUE
+
+C debug output
+ IF(IDEB(38).GE.5) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
+ DO 60 I=1,NKM
+ IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
+ & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
+ & DMX(2,I),DMX(3,I)
+ 60 CONTINUE
+ ENDIF
+
+ DO 70 I=-1,Max_pro_2
+ HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
+ 70 CONTINUE
+
+C debug output
+ IF(IDEB(38).GE.5) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
+ WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
+ DO 80 I=-1,Max_pro_2
+ IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
+ MSPR = I
+ X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
+ X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
+ PT = PTM(IFTAB(I))
+ CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
+ WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
+ ENDIF
+ 80 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARWGI.FOR
+*COPY PHO_HARWGI
+CDECK ID>, PHO_HARWGI
+ SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
+C**********************************************************************
+C
+C auxiliary subroutine to find maximum of remaining weight
+C
+C input: ECMX current CMS energy
+C PTCUT current pt cutoff
+C NKON process label 1..5 resolved
+C 6..7 direct particle 1
+C 8..9 direct particle 2
+C 10 double direct
+C Z(3) transformed variable
+C
+C output: remaining weight
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION Z(3)
+
+ PARAMETER ( NKM = 10 )
+ PARAMETER ( TINY = 1.D-30,
+ & TINY6 = 1.D-06 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
+
+ FDIS = 0.D0
+
+ IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
+ & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
+C check input values
+ IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
+ IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
+ IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
+C transformations
+ Y1 = EXP(ALNH*Z(1))
+ IF(NKON.LE.5) THEN
+C resolved kinematic
+ Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
+ X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
+ X2 = X1-Y2
+ X1 = MIN(X1,0.999999999999D0)
+ X2 = MIN(X2,0.999999999999D0)
+ ELSE IF(NKON.LE.7) THEN
+C direct kinematic 1
+ X1 = 1.D0
+ X2 = MIN(Y1,0.999999999999D0)
+ ELSE IF(NKON.LE.9) THEN
+C direct kinematic 2
+ X1 = MIN(Y1,0.999999999999D0)
+ X2 = 1.D0
+ ELSE
+C double direct kinematic
+ X1 = 1.D0
+ X2 = 1.D0
+ ENDIF
+ W = SQRT(MAX(TINY,1.D0-AH/Y1))
+ V =-0.5D0+W*(Z(3)-0.5D0)
+ U =-(1.D0+V)
+ PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
+
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
+ ENDIF
+C
+ IF(NKON.LE.5) THEN
+ DO 10 N=1,5
+ F(N) = 0.D0
+ 10 CONTINUE
+C resolved processes
+ ALPHA1 = PHO_ALPHAS(QQAL,3)
+ ALPHA2 = ALPHA1
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+C calculate full distribution FDIS
+ DO 20 I=1,NF
+ F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ F(4) = F(4)+PDA(I)+PDA(-I)
+ F(5) = F(5)+PDB(I)+PDB(-I)
+20 CONTINUE
+ F(1) = PDA(0)*PDB(0)
+ T = PDA(0)*F(5)+PDB(0)*F(4)
+ F(5) = F(4)*F(5)-(F(2)+F(3))
+ F(4) = T
+ ELSE IF(NKON.LE.7) THEN
+C direct processes particle 1
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ CH1 = 4.D0/9.D0
+ CH2 = 3.D0/9.D0
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ CH1 = 1.D0
+ CH2 = 0.D0
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ F(6) = 0.D0
+ DO 30 I=1,NF
+ F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
+ 30 CONTINUE
+ F(7) = PDB(0)
+ ELSE IF(NKON.LE.9) THEN
+C direct processes particle 2
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ CH1 = 4.D0/9.D0
+ CH2 = 3.D0/9.D0
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ CH1 = 1.D0
+ CH2 = 0.D0
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ F(8) = 0.D0
+ DO 40 I=1,NF
+ F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
+ 40 CONTINUE
+ F(9) = PDA(0)
+ ELSE
+C double direct process
+ SSR = ECMX*ECMX
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(SSR)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(SSR)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ F(10) = 1.D0
+ ENDIF
+
+ FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
+
+C debug output
+ IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
+ & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
+ & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
+
+ END
+
+*$ CREATE PHO_HARINI.FOR
+*COPY PHO_HARINI
+CDECK ID>, PHO_HARINI
+ SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
+C**********************************************************************
+C
+C initialize calculation of hard cross section
+C
+C must not be called during MC generation
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+
+ double precision pho_alphas
+
+ CHARACTER*20 RFLAG
+
+C set local Pomeron c.m. system data
+ IDPDG1 = IDP1
+ IDPDG2 = IDP2
+ PVIRTP(1) = PV1
+ PVIRTP(2) = PV2
+C initialize PDFs
+ CALL PHO_ACTPDF(IDPDG1,1)
+ CALL PHO_ACTPDF(IDPDG2,2)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+C initialize scales with defaults
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ AQQAL = PARMDL(83)
+ AQQALI = PARMDL(86)
+ AQQALF = PARMDL(89)
+ AQQPD = PARMDL(92)
+ NQQAL = IPAMDL(83)
+ NQQALI = IPAMDL(86)
+ NQQALF = IPAMDL(89)
+ NQQPD = IPAMDL(92)
+ ELSE
+ AQQAL = PARMDL(82)
+ AQQALI = PARMDL(85)
+ AQQALF = PARMDL(88)
+ AQQPD = PARMDL(91)
+ NQQAL = IPAMDL(82)
+ NQQALI = IPAMDL(85)
+ NQQALF = IPAMDL(88)
+ NQQPD = IPAMDL(91)
+ ENDIF
+ ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ AQQAL = PARMDL(82)
+ AQQALI = PARMDL(85)
+ AQQALF = PARMDL(88)
+ AQQPD = PARMDL(91)
+ NQQAL = IPAMDL(82)
+ NQQALI = IPAMDL(85)
+ NQQALF = IPAMDL(88)
+ NQQPD = IPAMDL(91)
+ ELSE
+ AQQAL = PARMDL(81)
+ AQQALI = PARMDL(84)
+ AQQALF = PARMDL(87)
+ AQQPD = PARMDL(90)
+ NQQAL = IPAMDL(81)
+ NQQALI = IPAMDL(84)
+ NQQALF = IPAMDL(87)
+ NQQPD = IPAMDL(90)
+ ENDIF
+ IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
+ IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
+ IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
+ IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
+ IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
+ IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
+ IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
+ IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
+ AQQAL = PARMDL(109+IP)
+ AQQALI = PARMDL(113+IP)
+ AQQALF = PARMDL(117+IP)
+ AQQPD = PARMDL(121+IP)
+ NQQAL = IPAMDL(64+IP)
+ NQQALI = IPAMDL(68+IP)
+ NQQALF = IPAMDL(72+IP)
+ NQQPD = IPAMDL(76+IP)
+ PTCUT(1) = PARMDL(36)
+ PTCUT(2) = PARMDL(37)
+ PTCUT(3) = PARMDL(38)
+ PTCUT(4) = PARMDL(39)
+ PTANO(1) = PARMDL(130)
+ PTANO(2) = PARMDL(131)
+ PTANO(3) = PARMDL(132)
+ PTANO(4) = PARMDL(133)
+ RFLAG = '(energy-independent)'
+ IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
+
+C write out all settings
+ IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
+ WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
+ & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
+ & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
+ & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
+1050 FORMAT(/,
+ & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
+ & 5X,'particle 1 / particle 2:',2I8,/,
+ & 5X,'min. PT :',F7.1,2X,A,/,
+ & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
+ & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
+ & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
+ & 5X,'max. number of active flavours NF :',I3,/,
+ & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARINT.FOR
+*COPY PHO_HARINT
+CDECK ID>, PHO_HARINT
+ SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
+C**********************************************************************
+C
+C interpolate cross sections and weights for hard scattering
+C
+C input: IPP particle combination (neg. for add. user cuts)
+C ECM CMS energy (GeV)
+C P2V1/2 particle virtualities (pos., GeV**2)
+C I1 first subprocess to calculate
+C I2 last subprocess to calculate
+C <-1 only scales and cutoffs calculated
+C K1 first variable to calculate
+C K2 last variable to calculate
+C MSPOM cross sections to use for pt distribution
+C 0 reggeon
+C >0 pomeron
+C
+C for K1 < 3 the soft pt distribution is also calculated
+C
+C output: interpolated values in HWgx, HSig, Hdpt
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & DEPS2 = 2.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ DOUBLE PRECISION XP,PTS
+ DIMENSION XP(2),PTS(0:2,2)
+
+ INTEGER IV
+ DIMENSION IV(2)
+
+ IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
+ & 'PHO_HARINT: called with ',
+ & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
+ & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
+
+ IP = ABS(IPP)
+ IF(IPP.GT.0) THEN
+C default minimum bias cutoff
+ PTCUT(IP) = pho_ptcut(ECM,IP)
+ ELSE
+C user defined additional cutoff
+ PTCUT(IP) = HSWCUT(4+IP)
+ ENDIF
+ PTWANT = PTCUT(IP)
+
+C ISR cutoffs
+ Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
+ Q2MISR(1) = MAX(P2V1,Q2CUT)
+ Q2MISR(2) = MAX(P2V2,Q2CUT)
+C cutoff for direct photon contribution to photon PDF
+ PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
+ PTA1 = PTANO(IP)
+C scales for hard scattering
+ AQQAL = PARMDL(109+IP)
+ AQQALI = PARMDL(113+IP)
+ AQQALF = PARMDL(117+IP)
+ AQQPD = PARMDL(121+IP)
+ NQQAL = IPAMDL(64+IP)
+ NQQALI = IPAMDL(68+IP)
+ NQQALF = IPAMDL(72+IP)
+ NQQPD = IPAMDL(76+IP)
+ IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
+ & 'PHO_HARINT: scales:',
+ & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
+
+ IF(I2.LT.-1) RETURN
+
+ IL = IP
+ IF(IPP.LT.0) IL = 0
+
+C double-log interpolation
+ IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
+ DO 50 M=I1,I2
+ Hfac(M) = 0.D0
+ HWgx(M) = 0.D0
+ HSig(M) = 0.D0
+ Hdpt(M) = 0.D0
+ 50 CONTINUE
+ ELSE
+ I=1
+ 310 CONTINUE
+ I = I+1
+ IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
+
+ Ia = 1
+ Ib = 1
+ fac = LOG(ECM/HEcm_tab(I-1,IL))
+ & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
+ do M=I1,I2
+C factor due to phase space integration
+ XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ Hfac(M) = XX
+C max. weight
+ XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ HWgx(M) = XX*1.2D0
+C hard cross section
+ XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ HSig(M) = XX
+C differential hard cross section
+ XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ Hdpt(M) = XX
+ enddo
+ ENDIF
+
+ IF((K1.LT.3).AND.(K2.GE.3)) THEN
+C cross check
+ IF((I1.GT.9).OR.(I2.LT.9)) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
+ & 'hard cross section not calculated ',I1,I2
+ ENDIF
+ SIGH = HSig(9)
+ DSIGHP = Hdpt(9)
+C load soft cross sections from interpolation table
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ L1 = 1
+ L2 = 1
+ ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 55 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 205
+ 55 CONTINUE
+ 205 CONTINUE
+ L1 = I-1
+ L2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
+ & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
+ & IP,ECM,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ L1 = ISIMAX-1
+ L2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
+ & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
+ FAC1=1.D0-FAC2
+ SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
+ & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
+
+ FS = FPS(IP)
+ FH = FPH(IP)
+ CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
+ ENDIF
+
+ 300 CONTINUE
+
+C debug output
+ IF(IDEB(58).GE.15) THEN
+ WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
+ & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
+ & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
+ DO 162 M=I1,I2
+ WRITE(LO,'(5X,2I3,1p,4E12.3)')
+ & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
+ 162 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PTCUT.FOR
+*COPY PHO_PTCUT
+ DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
+C***********************************************************************
+C
+C calculate energy-dependent transverse momentum cutoff
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ double precision ECM
+ integer IP
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ pho_ptcut = PARMDL(35+IP)
+
+ IF(IPAMDL(7).EQ.1) THEN
+C Bopp et al. type (DPMJET)
+ pho_ptcut = PARMDL(35+IP)
+ & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
+ ELSE IF(IPAMDL(7).EQ.2) THEN
+C Gribov-Levin-Ryskin type
+ pho_ptcut = PARMDL(35+IP)
+ & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARMCI.FOR
+*COPY PHO_HARMCI
+CDECK ID>, PHO_HARMCI
+ SUBROUTINE PHO_HARMCI(IP,EMAXF)
+C**********************************************************************
+C
+C initialize MC sampling and calculate hard cross section
+C
+C input: IP particle combination (neg. number for user cut)
+C EMAXF maximum CMS energy for
+C interpolation table in reference to PTCUT(1..4)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-10,
+ & PLARGE = 1.D20 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C hard cross sections and MC selection weights
+ INTEGER Max_pro_2
+ PARAMETER ( Max_pro_2 = 16 )
+ INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+ & MH_acc_1,MH_acc_2
+ DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+ COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+ & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+ & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+ & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+ & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ COMPLEX*16 DSIG
+ DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
+
+C initialization for all pt cutoffs
+ I = ABS(IP)
+ IL = I
+ IF(IP.LT.0) THEN
+ IL = 0
+ PTC = HSWCUT(4+I)
+ else
+ PTC = pho_ptcut(parmdl(19),I)
+ ENDIF
+
+C skip unassigned PTCUT
+ IF(PTC.LT.0.5D0) GOTO 1000
+
+ IH_Q2a_up(I) = 1
+ IH_Q2b_up(I) = 1
+ do ib=1,Max_tab_Q2
+ do ia=1,Max_tab_Q2
+ do ie=1,Max_tab_E
+ do m=-1,Max_pro_2
+ Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
+ HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
+ HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
+ Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ELLOW = LOG(2.05*PTC)
+ DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
+C energy too low
+ IF(DELTA.LE.0.D0) GOTO 1000
+
+C switch between external particles and Pomeron
+ IF(I.EQ.4) THEN
+ IDP1 = 990
+ PV1 = 0.D0
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE IF(I.EQ.3) THEN
+ IDP1 = IFPAP(2)
+ PV1 = PVIRT(2)
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE IF(I.EQ.2) THEN
+ IDP1 = IFPAP(1)
+ PV1 = PVIRT(1)
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE
+ IDP1 = IFPAP(1)
+ PV1 = PVIRT(1)
+ IDP2 = IFPAP(2)
+ PV2 = PVIRT(2)
+ ENDIF
+
+C initialize PT scales
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ FPS(I) = PARMDL(105)
+ FPH(I) = PARMDL(106)
+ ELSE
+ FPS(I) = PARMDL(103)
+ FPH(I) = PARMDL(104)
+ ENDIF
+ ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ FPS(I) = PARMDL(103)
+ FPH(I) = PARMDL(104)
+ ELSE
+ FPS(I) = PARMDL(101)
+ FPH(I) = PARMDL(102)
+ ENDIF
+
+C initialize hard scattering
+ IF(IP.GT.0) THEN
+ CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
+ ELSE
+ CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
+ ENDIF
+
+C energy/virtuality grid
+ do Ie=1,IH_Ecm_up(IL)
+ HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
+ enddo
+ do Ia=1,IH_Q2a_up(IL)
+ HQ2a_tab(Ia,IL) = 0.D0
+ enddo
+ do Ib=1,IH_Q2b_up(IL)
+ HQ2b_tab(Ib,IL) = 0.D0
+ enddo
+
+C initialization for several energies and particle virtualities
+ do Ie=1,IH_Ecm_up(IL)
+ do Ia=1,IH_Q2a_up(IL)
+ do Ib=1,IH_Q2b_up(IL)
+
+ EE = HEcm_tab(IE,IL)
+ Q2a = HQ2a_tab(Ia,IL)
+ Q2b = HQ2b_tab(Ib,IL)
+ CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
+ IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
+ & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
+ & PTCUT(I),EE,IDPDG1,IDPDG2
+ Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
+ CALL PHO_HARFAC(PTCUT(I),EE)
+ CALL PHO_HARWGX(PTCUT(I),EE)
+ CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
+ IF(IDEB(8).GE.10) THEN
+ WRITE(LO,'(1X,A,/,1X,A)')
+ & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
+ & '------------------------------------------------'
+ DO M=0,Max_pro_2
+ WRITE(LO,'(10X,A,1P2E14.4)')
+ & PROC(M),DREAL(DSIG(M)),DSPT(M)
+ ENDDO
+ ENDIF
+
+C store in interpolation tables
+ Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
+ HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
+ do M=0,Max_pro_2
+ Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
+ HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
+ HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
+ Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
+ enddo
+
+C summed quantities
+ HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
+ Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
+ do M=1,8
+ IF(MH_pro_on(M,I).GT.0) THEN
+ HSig_tab(9,IE,Ia,Ib,IL) =
+ & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
+ Hdpt_tab(9,IE,Ia,Ib,IL) =
+ & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
+ ENDIF
+ enddo
+ HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
+ Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
+ do M=10,14
+ IF(MH_pro_on(M,I).GT.0) THEN
+ HSig_tab(15,IE,Ia,Ib,IL) =
+ & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
+ Hdpt_tab(15,IE,Ia,Ib,IL) =
+ & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
+ ENDIF
+ enddo
+ HSig_tab(0,IE,Ia,Ib,IL) =
+ & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
+ Hdpt_tab(0,IE,Ia,Ib,IL) =
+ & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
+
+ enddo
+ enddo
+ enddo
+
+C debug output of weights
+ 1000 CONTINUE
+ IF(IDEB(8).GE.5) THEN
+ WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
+ & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
+ & IDPDG1,IDPDG2,IP,PTCUT(I),
+ & '------------------------------------------'
+ DO M=-1,Max_pro_2
+ IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
+ WRITE(LO,'(2X,A,I3,2I7)')
+ & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
+ & M,IDPDG1,IDPDG2
+ do k=1,IH_Ecm_up(IL)
+ do ia=1,IH_Q2a_up(IL)
+ do ib=1,IH_Q2b_up(IL)
+ WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
+ & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
+ & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
+ & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
+ enddo
+ enddo
+ enddo
+ 512 CONTINUE
+ ENDDO
+ ENDIF
+
+ END
+
+*$ CREATE PHO_HARXR3.FOR
+*COPY PHO_HARXR3
+CDECK ID>, PHO_HARXR3
+ SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DETAD*DPT)
+C
+C input: ECMH CMS energy
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C ETAD pseudorapidity of parton D
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ DIMENSION DSIGM(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+
+ DOUBLE PRECISION PHO_ALPHAS
+ DIMENSION PDA(-6:6),PDB(-6:6)
+
+ DO 10 I=1,9
+ DSIGMC(I) = CMPLX(0.D0,0.D0)
+ DSIGM(I) = 0.D0
+10 CONTINUE
+
+ EC = EXP(ETAC)
+ ED = EXP(ETAD)
+C kinematic conversions
+ XA = PT*(EC+ED)/ECMH
+ XB = XA/(EC*ED)
+ IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
+ WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA = PHO_ALPHAS(QQAL,3)
+ FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
+C parton distributions (times x)
+ CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
+ S1 = PDA(0)*PDB(0)
+ S2 = 0.D0
+ S3 = 0.D0
+ S4 = 0.D0
+ S5 = 0.D0
+ DO 20 I=1,NF
+ S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ S4 = S4+PDA(I)+PDA(-I)
+ S5 = S5+PDB(I)+PDB(-I)
+20 CONTINUE
+C partial cross sections (including color and symmetry factors)
+C resolved photon matrix elements (light quarks)
+ DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
+ DSIGM(6) = (4.D0/9.D0)*(UU+TT)
+ DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
+ DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
+ DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
+ DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
+ DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
+ DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
+ & (8.D0/27.D0)/(UP*TP))
+C
+ DSIGM(1) = FACTOR*DSIGM(1)*S1
+ DSIGM(2) = FACTOR*DSIGM(2)*S2
+ DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
+ DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
+ DSIGM(5) = FACTOR*DSIGM(5)*S2
+ DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
+ DSIGM(7) = FACTOR*DSIGM(7)*S3
+ DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 50 I=1,8
+ IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
+ 50 CONTINUE
+ END
+
+*$ CREATE PHO_HARXR2.FOR
+*COPY PHO_HARXR2
+CDECK ID>, PHO_HARXR2
+ SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DPT)
+C
+C input: ECMH CMS energy
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-20 )
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DO 10 M=1,9
+ DSIGMC(M) = CMPLX(0.D0,0.D0)
+ DSIG1(M) = 0.D0
+10 CONTINUE
+C
+ EC = EXP(ETAC)
+ ARG = ECMH/PT
+ IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
+ EDU = LOG(ARG-EC)
+ EDL =-LOG(ARG-1.D0/EC)
+ NPOINT = NGAUET
+ CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
+ DO 20 M=1,9
+ PCTRL= DREAL(DSIG1(M))/TINY
+ IF( PCTRL.GE.1.D0 ) THEN
+ DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
+ ENDIF
+20 CONTINUE
+30 CONTINUE
+ END
+
+*$ CREATE PHO_HARXD2.FOR
+*COPY PHO_HARXD2
+CDECK ID>, PHO_HARXD2
+ SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DPT) for direct processes
+C
+C input: ECMH CMS energy of scattering system
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
+
+* ONE32=1.D0/9.D0
+* TWO32=4.D0/9.D0
+ DO 10 I=10,13
+ DSIGMC(I) = CMPLX(0.D0,0.D0)
+ DSIGM(I) = 0.D0
+ 10 CONTINUE
+ DSIGMC(15) = CMPLX(0.D0,0.D0)
+ DSIGM(15) = 0.D0
+
+C direct particle 1
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ EC = EXP(ETAC)
+ ED = ECMH/PT-EC
+C kinematic conversions
+ XA = 1.D0
+ XB = 1.D0/(EC*ED)
+ IF ( XB.GE.1.D0 ) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
+C parton distribution (times x)
+ CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
+ S1 = PDB(0)
+C charge counting
+ S2 = 0.D0
+ S3 = 0.D0
+ IF(IDPDG1.EQ.22) THEN
+ DO 20 I=1,NF
+* IF(MOD(I,2).EQ.0) THEN
+* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
+* S3 = S3 + TWO32
+* ELSE
+* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
+* S3 = S3 + ONE32
+* ENDIF
+ S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
+ S3 = S3 + Q_ch2(I)
+ 20 CONTINUE
+ ELSE IF(IDPDG1.EQ.990) THEN
+ DO 25 I=1,NF
+ S2 = S2 + PDB(I)+PDB(-I)
+ 25 CONTINUE
+ S3 = NF
+ ENDIF
+C partial cross sections (including color and symmetry factors)
+C direct photon matrix elements
+ DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
+ DSIGM(11) = (UU+TT)/(UP*TP)
+C
+ DSIGM(10) = FACTOR*DSIGM(10)*S2
+ DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 50 I=10,11
+ IF(DSIGM(I).LT.0.D0) THEN
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
+ DSIGM(I) = 0.D0
+ ENDIF
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
+ 50 CONTINUE
+ ENDIF
+C
+C direct particle 2
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ EC = EXP(ETAC)
+ ED = 1.D0/(ECMH/PT-1.D0/EC)
+C kinematic conversions
+ XA = PT*(EC+ED)/ECMH
+ XB = 1.D0
+ IF ( XA.GE.1.D0 ) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
+C parton distribution (times x)
+ CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
+ S1 = PDA(0)
+C charge counting
+ S2 = 0.D0
+ S3 = 0.D0
+ IF(IDPDG2.EQ.22) THEN
+ DO 70 I=1,NF
+* IF(MOD(I,2).EQ.0) THEN
+* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
+* S3 = S3 + TWO32
+* ELSE
+* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
+* S3 = S3 + ONE32
+* ENDIF
+ S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
+ S3 = S3 + Q_ch2(I)
+ 70 CONTINUE
+ ELSE IF(IDPDG2.EQ.990) THEN
+ DO 75 I=1,NF
+ S2 = S2 + PDA(I)+PDA(-I)
+ 75 CONTINUE
+ S3 = NF
+ ENDIF
+C partial cross sections (including color and symmetry factors)
+C direct photon matrix elements
+ DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
+ DSIGM(13) = (UU+TT)/(UP*TP)
+C
+ DSIGM(12) = FACTOR*DSIGM(12)*S2
+ DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 80 I=12,13
+ IF(DSIGM(I).LT.0.D0) THEN
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
+ DSIGM(I) = 0.D0
+ ENDIF
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
+ 80 CONTINUE
+ ENDIF
+ END
+
+*$ CREATE PHO_HARXPT.FOR
+*COPY PHO_HARXPT
+CDECK ID>, PHO_HARXPT
+ SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/DPT
+C
+C input: ECMH CMS energy of scattering system
+C PT parton PT
+C IPRO 1 resolved processes
+C 2 direct processes
+C 3 resolved and direct processes
+C
+C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ double precision pho_alphae
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DO 10 M=0,Max_pro_2
+ DSIGMC(M) = CMPLX(0.D0,0.D0)
+ DSIG1(M) = CMPLX(0.D0,0.D0)
+ 10 CONTINUE
+
+C resolved and direct processes
+ AMT = 2.D0*PT/ECMH
+ IF ( AMT.GE.1.D0 ) RETURN
+ ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
+ ECL = -ECU
+ NPOINT = NGAUET
+ CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ DSIG1(9) = CMPLX(0.D0,0.D0)
+ DSIG1(15) = CMPLX(0.D0,0.D0)
+ IF(IPRO.EQ.1) THEN
+ CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
+ ELSE IF(IPRO.EQ.2) THEN
+ CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
+ ELSE
+ CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
+ CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
+ ENDIF
+ DO 20 M=1,Max_pro_2
+ DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
+ 20 CONTINUE
+ 30 CONTINUE
+
+C direct processes
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FAC = 0.D0
+ SS = ECMH*ECMH
+ ALPHAE = pho_alphae(SS)
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F1 = Q_ch2(I)*ALPHAE
+ ELSE
+ F1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F2 = Q_ch2(I)*ALPHAE
+ ELSE
+ F2 = PARMDL(74)
+ ENDIF
+ FAC = FAC+F1*F2*3.D0
+ 300 CONTINUE
+C direct cross sections
+ ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
+ T1 = -SS/2.D0*(1.D0+ZZ)
+ T2 = -SS/2.D0*(1.D0-ZZ)
+ XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
+C hadronic part
+ DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
+
+C leptonic part (e, mu, tau)
+ DSIGMC(16) = 0.D0
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
+ DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
+C simulation of tau together with quarks
+ IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
+ ENDIF
+ ENDIF
+
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
+ DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
+
+ END
+
+*$ CREATE PHO_HARXTO.FOR
+*COPY PHO_HARXTO
+CDECK ID>, PHO_HARXTO
+ SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
+C**********************************************************************
+C
+C total hard cross section (perturbative QCD, Parton Model)
+C
+C input: ECMH CMS energy of scattering system
+C PTCUTR PT cutoff for resolved processes
+C PTCUTD PT cutoff for direct processes (photon, Pomeron)
+C
+C output: DSIGMC(0:MARPR2) cross sections for given cutoff
+C DSDPTC(0:MARPR2) differential cross sections at cutoff
+C
+C note: COMPLEX*16 DSIGMC
+C DOUBLE PRECISION DSDPTC
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+
+ double precision pho_alphae
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DATA FAC / 3.0D0 /
+
+ DO 10 M=0,Max_pro_2
+ DSIGMC(M)= CMPLX(0.D0,0.D0)
+ 10 CONTINUE
+ EEC=ECMH/2.001D0
+C
+ IF ( PTCUTR.GE.EEC ) GOTO 100
+C
+C integration for resolved processes
+ PTMIN = PTCUTR
+ PTMAX = MIN(FAC*PTMIN,EEC)
+ NPOINT = NGAUP1
+ CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
+ DO 60 M=1,9
+ DSDPTC(M) = DREAL(DSIG1(M))
+ 60 CONTINUE
+ DSIGH = DREAL(DSIG1(9))
+ PTMXX = 0.95D0*PTMAX
+ CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
+ DSIGL = DREAL(DSIG1(9))
+ EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
+ EX1 = 1.0D0-EX
+ DO 50 K=1,2
+ IF ( PTMIN.GE.PTMAX ) GOTO 40
+ RL = PTMIN**EX1
+ RU = PTMAX**EX1
+ CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ R = ABSZ(I)
+ PT = R**(1.0D0/EX1)
+ CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
+ F = WEIG(I)*PT/(R*EX1)
+ DO 20 M=1,9
+ DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 PTMIN = PTMAX
+ PTMAX = EEC
+ NPOINT = NGAUP2
+ 50 CONTINUE
+ 100 CONTINUE
+ DSIGMC(0) = DSIGMC(9)
+ DSDPTC(0) = DSDPTC(9)
+C
+C integration for direct processes
+ IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
+C
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
+ & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ PTMIN = PTCUTD
+ PTMAX = MIN(FAC*PTMIN,EEC)
+ NPOINT = NGAUP1
+ CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
+ IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
+ DO 160 M=10,16
+ DSDPTC(M) = DREAL(DSIG1(M))
+ 160 CONTINUE
+ DSIGH = DREAL(DSIG1(15)-DSIG1(14))
+ PTMXX = 0.95D0*PTMAX
+ CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
+ DSIGL = DREAL(DSIG1(15)-DSIG1(14))
+ EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
+ EX1 = 1.0D0-EX
+ DO 150 K=1,2
+ IF ( PTMIN.GE.PTMAX ) GOTO 140
+ RL = PTMIN**EX1
+ RU = PTMAX**EX1
+ CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
+ DO 130 I=1,NPOINT
+ R = ABSZ(I)
+ PT = R**(1.0D0/EX1)
+ CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
+ F = WEIG(I)*PT/(R*EX1)
+ DO 120 M=10,15
+ DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 PTMIN = PTMAX
+ PTMAX = EEC
+ NPOINT = NGAUP2
+ 150 CONTINUE
+ ENDIF
+C
+ 170 CONTINUE
+C
+C double direct process
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FACC = 0.D0
+ SS = ECMH*ECMH
+ ALPHAE = pho_alphae(SS)
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F1 = Q_ch2(I)*ALPHAE
+ ELSE
+ F1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F2 = Q_ch2(I)*ALPHAE
+ ELSE
+ F2 = PARMDL(74)
+ ENDIF
+ FACC = FACC + F1*F2*3.D0
+ 300 CONTINUE
+
+ ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
+ R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
+C hadronic cross section
+ DSIGMC(14) = R*FACC*AKFAC
+C leptonic cross section
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
+ DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
+C simulation of tau together with quarks
+ IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
+ DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
+ ELSE
+ DSIGMC(16) = CMPLX(0.D0,0.D0)
+ ENDIF
+C sum of direct part
+ DSIGMC(15) = CMPLX(0.D0,0.D0)
+ DO 400 I=10,14
+ DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
+ 400 CONTINUE
+ ENDIF
+C total sum (hadronic)
+ DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
+ DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
+
+ END
+
+*$ CREATE PHO_HARISR.FOR
+*COPY PHO_HARISR
+CDECK ID>, PHO_HARISR
+ SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
+ & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
+C********************************************************************
+C
+C initial state radiation according to DGLAP evolution equations
+C (backward evolution, no spin effects)
+C
+C input: IHPOM index of hard Pomeron
+C negative: delete all previous entries
+C P1,P2 4 momenta of hard scattered final partons
+C (in CMS of hard scattering)
+C IPF1,2 flavours of final partons
+C IPA1,2 flavours of initial partons
+C IV1,2 valence quark labels (0/1)
+C Q2H momentum transfer (squared, positive)
+C XH1,XH2 x values of initial partons
+C XHMAX1,2 max. x values allowed
+C
+C output: all emitted partons in /POPISR/, final state
+C partons are the first two entries
+C shower evolution traced in /PODGL1/
+C IPB1,2 flavours of new initial partons
+C XISR1,2 x values of new initial partons
+C IVO1,2 valence quark labels (0/1)
+C
+C attention: quark numbering according to PDG convention,
+C but 0 for gluons
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (RHOMAS = 0.766D0,
+ & DEPS = 1.D-10,
+ & TINY = 1.D-10)
+
+ DIMENSION P1(4),P2(4)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+C initial state parton radiation (internal part)
+ INTEGER MXISR3,MXISR4
+ PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
+ INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
+ DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
+ COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
+ & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
+ & IFL1(2,MXISR3),IFL2(2,MXISR3),
+ & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+
+ DOUBLE PRECISION PYP,EER,THER,QMAXR
+ INTEGER PYK
+
+ DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
+ & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
+ & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
+
+ IREJ = 0
+ NTRY = 1000
+ NITER = 0
+C debug output
+ IF(IDEB(79).GE.10) THEN
+ WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
+ & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
+ & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
+ ENDIF
+ IF(IHPOM.EQ.0) RETURN
+C
+ 10 CONTINUE
+ NACC = 0
+ IDMO(1) = IDPDG1
+ IDMO(2) = IDPDG2
+C
+C copy final state partons to local fields
+ IHIDX = ABS(IHPOM)
+
+ IF(IHIDX.GT.MXISR2) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
+ & IHIDX,MXISR2
+ IREJ = 1
+ ENDIF
+
+ DO 50 K=1,2
+ IF(IHPOM.LT.0) IMXISR(K) = 0
+ IPOISR(K,1,IHIDX) = IMXISR(K)+1
+ IPAL(K) = IPOISR(K,1,IHIDX)
+ 50 CONTINUE
+ DO 55 I=1,4
+ PHISR(1,I,IPAL(1)) = P1(I)
+ PHISR(2,I,IPAL(2)) = P2(I)
+ 55 CONTINUE
+ IFLISR(1,IPAL(1)) = IPF1
+ IFLISR(2,IPAL(2)) = IPF2
+C
+C check limitations, initialize /PODGL1/
+ IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
+ NEXT(1) = 1
+ Q2SH(1,1) = Q2H
+ ELSE
+ NEXT(1) = 0
+ Q2SH(1,1) = 0.D0
+ ENDIF
+ IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
+ NEXT(2) = 1
+ Q2SH(2,1) = Q2H
+ ELSE
+ NEXT(2) = 0
+ Q2SH(2,1) = 0.D0
+ ENDIF
+C
+ ISH(1) = 1
+ ISH(2) = 1
+ XPSH(1,1) = XH1
+ XPSH(2,1) = XH2
+C
+ IFL1(1,1) = IPA1
+ IVAL(1) = IV1
+ IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
+ IFL1(2,1) = IPA2
+ IVAL(2) = IV2
+ IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
+C
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
+ & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
+ IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
+C
+C initialize parton shower loop
+ B0QCD = (33.D0-2.D0*NFSISR)/6.D0
+ AL2ISR(1) = PDFLAM(1)
+ AL2ISR(2) = PDFLAM(2)
+ XHMA(1) = XHMAX1
+ XHMA(2) = XHMAX2
+ XHMI(1) = PMISR(1)/PCMP
+ XHMI(2) = PMISR(2)/PCMP
+ ZPSH(1,1) = 1.D0
+ ZPSH(2,1) = 1.D0
+ SHAT1 = XH1*XH2*ECMP**2
+ IF(IPAMDL(109).EQ.1) THEN
+ PT2SH(1,1) = Q2H
+ ELSE
+ PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
+ ENDIF
+ PT2SH(2,1) = PT2SH(1,1)
+ IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
+ IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
+ THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
+ THSH(2,1) = THSH(1,1)
+ IFANO(1) = 0
+ IFANO(2) = 0
+ ZZ = 1.D0
+ IF(IREJ.NE.0) GOTO 800
+C
+C main generation loop
+C -------------------------------------------------
+ 100 CONTINUE
+C choose parton side to become solved
+ IF((NEXT(1)+NEXT(2)).EQ.2) THEN
+ IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
+ IP = 1
+ ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
+ IP = 2
+ ELSE
+ IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
+ ENDIF
+ ELSE IF(NEXT(1).EQ.1) THEN
+ IP = 1
+ ELSE IF(NEXT(2).EQ.1) THEN
+ IP = 2
+ ELSE
+ GOTO 800
+ ENDIF
+ INDX = ISH(IP)
+C INDX now parton position of parton to become solved
+C IP now side to be treated
+ XP = XPSH(IP,INDX)
+ Q2P = Q2SH(IP,INDX)
+ PT2 = PT2SH(IP,INDX)
+ IFLB = IFL1(IP,INDX)
+C check available x
+ XMIP = XHMI(IP)
+C cutoff by x limitation: no further development
+ IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
+ NEXT(IP) = 0
+ Q2SH(IP,INDX) = 0.D0
+ IF(IDEB(79).GE.17) THEN
+ WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
+ & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
+ & XP,XMIP,XHMA(IP),IP,INDX
+ ENDIF
+ GOTO 100
+ ENDIF
+C initial value of evolution variable t
+ TT = LOG(AQQALI*Q2P/AL2ISR(IP))
+ DO 110 I=-NFSISR,NFSISR
+ WGGAP(I) = 0.D0
+ WGPDF(I) = 0.D0
+ 110 CONTINUE
+C DGLAP weights
+ ZMIN = XP/XHMA(IP)
+ ZMAX = XP/(XP+XMIP)
+ CF = 4./3.
+C q --> q g, g --> g g
+ IF(IFLB.EQ.0) THEN
+ WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
+ & +2.D0*LOG(ZMAX/ZMIN))
+ DO 120 I=1,NFSISR
+ WGGAP(I) = WGGAP(0)
+ WGGAP(-I) = WGGAP(0)
+ 120 CONTINUE
+ WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
+ & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
+C q --> g q, g --> q qb
+ ELSE IF(ABS(IFLB).LE.6) THEN
+ WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
+ & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
+ IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
+ & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
+ ELSE
+ WRITE(LO,'(/1X,A,I7)')
+ & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
+ CALL PHO_ABORT
+ ENDIF
+C anomalous/resolved evolution
+ IPDFC = 0
+ IF(IPAMDL(110).GE.1) THEN
+ IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
+ & .AND.(IFLB.NE.21)) THEN
+ WGDIR = 0.D0
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2*AQQPD
+ ELSE
+ SCALE2 = Q2P*AQQPD
+ ENDIF
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ IPDFC = 1
+ CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
+ XI = DT_RNDM(XP)*PD1(IFLB)
+ IF(WGDIR.GT.XI) THEN
+C debug output
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
+ & 'PHO_HARISR: ',
+ & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
+ & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IFANO(IP) = INDX
+ GOTO 100
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C rejection loop for z,t sampling
+C ------------------------------------
+ 200 CONTINUE
+ NITER = NITER+1
+ IF(NITER.GE.NTRY) THEN
+ WRITE(LO,'(1X,A,2I6)')
+ & 'PHO_HARISR: too many rejections',NITER,NTRY
+ CALL PHO_PREVNT(-1)
+C clean up event
+ IREJ = 1
+ GOTO 10
+ ENDIF
+C PDF weights
+ IF(IPDFC.EQ.0) THEN
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2*AQQPD
+ ELSE
+ SCALE2 = Q2P*AQQPD
+ ENDIF
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ ENDIF
+ IPDFC = 0
+C
+ WGTOT = 0.D0
+ DO 210 I=-NFSISR,NFSISR
+ WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
+ WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
+ 210 CONTINUE
+C
+ 215 CONTINUE
+C sample new t value
+ TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
+ Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
+ & 'PHO_HARISR: pre-selected Q2:',Q2NEW
+C compare to limits
+ IF(Q2NEW.LT.Q2MISR(IP)) THEN
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
+ & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
+ & Q2NEW,Q2MISR(IP),IP,INDX
+ GOTO 100
+ ENDIF
+ Q2SH(IP,INDX) = Q2NEW
+ TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
+C selection of flavours
+ XI = WGTOT*DT_RNDM(TT)
+ IFLA = -NFSISR-1
+ 220 CONTINUE
+ IFLA = IFLA+1
+ XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
+ IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
+ & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
+C selection of z
+ CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: pre-selected ZZ',ZZ
+C angular ordering
+ THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
+ IF(THETA.GT.THSH(IP,INDX)) THEN
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
+ & 'PHO_HARISR: reject by angle (NEW/OLD)',
+ & THETA,THSH(IP,INDX)
+ GOTO 215
+ ENDIF
+C rejection weight given by new PDFs
+ XNEW = XP/ZZ
+ PT2NEW = Q2NEW*(1.D0-ZZ)
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2NEW*AQQPD
+ ELSE
+ SCALE2 = Q2NEW*AQQPD
+ ENDIF
+ IF(SCALE2.LT.Q2MISR(IP)) THEN
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
+ & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
+ & Q2NEW,Q2MISR(IP),IP,INDX
+ GOTO 100
+ ENDIF
+ CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
+ IF(PD2(IFLA).LT.1.D-10) GOTO 200
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
+ WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
+ IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
+ & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
+ IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
+ WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: final weight:',WGF
+ WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
+ & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
+ ENDIF
+ IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
+
+ IF(IDEB(79).GE.15) THEN
+ WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
+ & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
+ & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
+ ENDIF
+
+ IF(INDX.GE.MXISR3) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
+ IREJ = 1
+ RETURN
+ ENDIF
+
+C branching accepted, registration
+ Q2SH(IP,INDX) = Q2NEW
+ PT2SH(IP,INDX) = PT2NEW
+ ZPSH(IP,INDX) = ZZ
+ IFL2(IP,INDX) = IFLA-IFLB
+ Q2SH(IP,INDX+1) = Q2NEW
+ PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
+ XPSH(IP,INDX+1) = XNEW
+ THSH(IP,INDX+1) = THETA
+ IFL1(IP,INDX+1) = IFLA
+ ISH(IP) = ISH(IP)+1
+
+ NACC = NACC+1
+
+ IF(NACC.GT.MXISR4) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ SHAT(NACC) = SHAT1
+ IBRA(1,NACC) = IP
+ IBRA(2,NACC) = INDX
+ SHAT1 = SHAT1/ZZ
+
+C generation of next branching
+ IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
+
+ 800 CONTINUE
+
+C new initial flavours, x values
+ IPB1 = IFL1(1,ISH(1))
+ IPB2 = IFL1(2,ISH(2))
+ XISR1 = XPSH(1,ISH(1))
+ XISR2 = XPSH(2,ISH(2))
+ IVO1 = IVAL(1)
+ IVO2 = IVAL(2)
+C valence flavours
+ IF(IPB1.NE.0) THEN
+ IF(ISH(1).GT.1) THEN
+ CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
+ IF(IDPDG1.EQ.22) THEN
+ CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
+ IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
+ ELSE
+ CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
+ IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IPB2.NE.0) THEN
+ IF(ISH(2).GT.1) THEN
+ CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
+ IF(IDPDG2.EQ.22) THEN
+ CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
+ IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
+ ELSE
+ IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+C parton kinematics
+ IF(NACC.GT.0) THEN
+C final partons in CMS
+ PM(3) = (XH1-XH2)*ECMP/2.D0
+ PM(4) = (XH1+XH2)*ECMP/2.D0
+ SH = XH1*XH2*ECMP**2
+ SSH = SQRT(SH)
+ GB(3) = PM(3)/SSH
+ GB(4) = PM(4)/SSH
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
+ & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
+ & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
+ & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
+ & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
+ IL(1) = 1
+ IL(2) = 1
+ DO 900 I=1,NACC
+ IPA = IBRA(1,I)
+ IPB = 3-IPA
+ IL(IPA) = IBRA(2,I)
+C new initial partons in CMS
+ SH = SHAT(I)
+ SSH = SQRT(SH)
+ SHZ = SH/ZPSH(IPA,IL(IPA))
+ SSHZ = SQRT(SHZ)
+ Q2(1) = Q2SH(1,IL(1))
+ Q2(2) = Q2SH(2,IL(2))
+ PC(1,1) = 0.D0
+ PC(1,2) = 0.D0
+ PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
+ & /(2.D0*SSH)
+ PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
+ PC(2,1) = 0.D0
+ PC(2,2) = 0.D0
+ PC(2,3) = -PC(1,3)
+ PC(2,4) = SSH-PC(1,4)
+ XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
+ EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
+ S1 = SH+Q2(IPA)+Q2(IPB)
+ S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
+ R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
+ R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
+ IF(Q2(IPB).LT.0.1D0) THEN
+ XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
+ & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
+ ELSE
+ XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
+ & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
+ ENDIF
+ NGEN = 1
+C max. virtuality for time-like showers
+ QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
+ IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
+C generate time-like parton shower
+ KF = IFL2(IPA,IL(IPA))
+ IF(KF.EQ.0) KF = 21
+ EER = MIN(EE3-PC(IPA,4),ECMP)
+ THER = 0.
+
+ CALL PY1ENT(1,KF,EER,THER,THER)
+ QMAXR = SQRT(QMAX)
+ CALL PYSHOW(1,0,QMAXR)
+C debug output
+ IF(IDEB(79).GE.25) THEN
+ WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
+ & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
+ & EER,QMAX,XMS4M,Q2(IPA)
+ CALL PYLIST(1)
+ ENDIF
+ NGEN = PYK(0,1)
+
+ IF(NGEN.GT.1) THEN
+ PJX = 0.D0
+ PJY = 0.D0
+ PJZ = 0.D0
+ PJE = 0.D0
+ KK = IPAL(IPA)
+ DO 820 K=3,NGEN
+
+ IF(PYK(K,1).LE.4) THEN
+ KK = KK+1
+
+ IF(KK.GT.MXISR1) THEN
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
+ & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ PHISR(IPA,1,KK) = PYP(K,1)
+ PJX = PJX+PHISR(IPA,1,KK)
+ PHISR(IPA,2,KK) = PYP(K,2)
+ PJY = PJY+PHISR(IPA,2,KK)
+ PHISR(IPA,3,KK) = PYP(K,3)
+ PJZ = PJZ+PHISR(IPA,3,KK)
+ PHISR(IPA,4,KK) = PYP(K,4)
+ PJE = PJE+PHISR(IPA,4,KK)
+ IFLISR(IPA,KK) = PYK(K,2)
+
+ IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
+ IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
+ IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
+ ENDIF
+ 820 CONTINUE
+ NGEN = KK-IPAL(IPA)
+ XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
+ PP4 = SQRT(PJE**2-XMS4)
+ EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
+ & 'PHO_HARISR: ',
+ & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
+ & PJE,PJX,PJY,PJZ,PP4,XMS4
+ ENDIF
+ ENDIF
+ PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
+ & /(2.D0*PC(IPA,3))
+ PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
+ IF(PT3.LT.0.D0) THEN
+ IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: rejection due to PT3',PT3
+ GOTO 10
+ ENDIF
+ PT3 = SQRT(PT3)
+ CALL PHO_SFECFE(SFE,CFE)
+ PX3 = CFE*PT3
+ PY3 = SFE*PT3
+C
+ IF(NGEN.GT.1) THEN
+C time-like shower generated
+ EE4 = EE3-PC(IPA,4)
+ PZ4 = PZ3-PC(IPA,3)
+ PP4 = SQRT(PT3**2+PZ4**2)
+C Lorentz boost
+ GAM = (EE4*PJE-PP4*PJZ)/XMS4
+ BEG = (PJE*PP4-EE4*PJZ)/XMS4
+C rotation angles
+ CODD = PZ4/PP4
+ SIDD = SQRT(PX3**2+PY3**2)/PP4
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PP4*SIDD.GT.1.D-5) THEN
+ COFD = PX3/(SIDD*PP4)
+ SIFD = PY3/(SIDD*PP4)
+ ANORF = SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C copy partons back
+ KK = IPAL(IPA)
+ DO 830 K=1,NGEN
+ KK = KK+1
+ PX = PHISR(IPA,1,KK)
+ PY = PHISR(IPA,2,KK)
+ PZ = PHISR(IPA,3,KK)
+ COH= PHISR(IPA,4,KK)
+ EE = GAM*COH+BEG*PZ
+ PZ = GAM*PZ +BEG*COH
+ PHISR(IPA,4,KK) = EE
+ CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
+ & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
+ 830 CONTINUE
+ IPAL(IPA) = KK
+ ELSE
+C no time-like shower generated
+ IPAL(IPA) = IPAL(IPA)+1
+ PHISR(IPA,1,IPAL(IPA)) = PX3
+ PHISR(IPA,2,IPAL(IPA)) = PY3
+ PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
+ PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
+ IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
+ ENDIF
+ PC(IPA,1) = PX3
+ PC(IPA,2) = PY3
+ PC(IPA,3) = PZ3
+ PC(IPA,4) = EE3
+C boost / rotate into new CMS
+ DO 842 K=1,4
+ GB(K) = (PC(1,K)+PC(2,K))/SSHZ
+ 842 CONTINUE
+ CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
+ & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
+ COG= PM(3)/PTOT1
+ SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
+ COH=1.D0
+ SIH=0.D0
+ IF(PTOT1*SIG.GT.1.D-5) THEN
+ COH=PM(1)/(SIG*PTOT1)
+ SIH=PM(2)/(SIG*PTOT1)
+ ANORF=SQRT(COH*COH+SIH*SIH)
+ COH=COH/ANORF
+ SIH=SIH/ANORF
+ ENDIF
+ DO 845 K=1,2
+ DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
+ CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
+ & PTOT1,PM(1),PM(2),PM(3),PM(4))
+ CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
+ & PN(2),PN(3))
+ CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
+ PHISR(K,4,L) = PM(4)
+ 844 CONTINUE
+ 845 CONTINUE
+ 900 CONTINUE
+C boost back to global CMS
+ PM(3) = (XISR1-XISR2)/2.D0
+ PM(4) = (XISR1+XISR2)/2.D0
+ SSH = SQRT(XISR1*XISR2)
+ GB(3) = PM(3)/SSH
+ GB(4) = PM(4)/SSH
+ DO 945 K=1,2
+ DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
+ & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
+ & PM(2),PM(3),PM(4))
+ PHISR(K,1,L) = PM(1)
+ PHISR(K,2,L) = PM(2)
+ PHISR(K,3,L) = PM(3)
+ PHISR(K,4,L) = PM(4)
+ 944 CONTINUE
+ 945 CONTINUE
+ ENDIF
+ IPOISR(1,2,IHIDX) = IPAL(1)
+ IPOISR(2,2,IHIDX) = IPAL(2)
+ IMXISR(1) = IPAL(1)
+ IMXISR(2) = IPAL(2)
+C
+C debug output
+ IF(IDEB(79).GE.10) THEN
+ WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
+ & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
+ IF(NACC.GT.0) THEN
+ WRITE(LO,'(1X,A,2I5,/6X,A)')
+ & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
+ & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
+ DO 600 II=1,NACC
+ K = IBRA(1,II)
+ I = IBRA(2,II)
+ WRITE(LO,'(5X,4I5,4E11.3)')
+ & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
+ & ZPSH(K,I)
+ 600 CONTINUE
+ ENDIF
+C check of final configuration
+ PX3 = 0.D0
+ PY3 = 0.D0
+ PZ3 = 0.D0
+ EE3 = 0.D0
+ IFSUM(1) = 0
+ IFSUM(2) = 0
+ WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
+ DO 745 K=1,2
+ DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
+ WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
+ IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
+ PX3 = PX3 + PHISR(K,1,L)
+ PY3 = PY3 + PHISR(K,2,L)
+ PZ3 = PZ3 + PHISR(K,3,L)
+ EE3 = EE3 + PHISR(K,4,L)
+ 744 CONTINUE
+ 745 CONTINUE
+ IFSUM(1) = IFSUM(1)-IPB1
+ IFSUM(2) = IFSUM(2)-IPB2
+ PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
+ EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
+ WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
+ & IFSUM,PX3,PY3,PZ3,EE3
+ ENDIF
+ END
+
+*$ CREATE PHO_HARZSP.FOR
+*COPY PHO_HARZSP
+CDECK ID>, PHO_HARZSP
+ SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
+C*********************************************************************
+C
+C sampling of z values from DGLAP kernels
+C
+C input: IFLA,IFLB parton flavours
+C NFSH flavours involved in hard processes
+C ZMIN minimal ZZ allowed
+C ZMAX maximal ZZ allowed
+C
+C output: ZZ z value
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IF(ZMAX.LE.ZMIN) THEN
+ WRITE(LO,'(1X,A,2E12.3)')
+ & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
+ CALL PHO_PREVNT(-1)
+ ZZ = 0.D0
+ RETURN
+ ENDIF
+C
+ IF(IFLB.EQ.0) THEN
+ IF(IFLA.EQ.0) THEN
+C g --> g g
+ C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
+ C2 = (1.D0-ZMIN)/ZMIN
+ 100 CONTINUE
+ ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
+ IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
+ ELSE IF(ABS(IFLA).LE.NFSH) THEN
+C q --> q g
+ C1 = ZMAX/ZMIN
+ 200 CONTINUE
+ ZZ = ZMIN*C1**DT_RNDM(ZMIN)
+ IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
+ ELSE
+ GOTO 900
+ ENDIF
+ ELSE IF(ABS(IFLB).LE.NFSH) THEN
+ IF(IFLA.EQ.0) THEN
+C g --> q qb
+ C1 = ZMAX-ZMIN
+ 300 CONTINUE
+ ZZ = ZMIN+C1*DT_RNDM(ZMIN)
+ IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
+ ELSE IF(ABS(IFLA).LE.NFSH) THEN
+C q --> g q
+ C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
+ C2 = 1.D0-ZMIN
+ 400 CONTINUE
+ ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
+ IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
+ ELSE
+ GOTO 900
+ ENDIF
+ ELSE
+ GOTO 900
+ ENDIF
+C debug output
+ IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
+ & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
+ & IFLA,IFLB,ZZ,ZMIN,ZMAX
+ RETURN
+
+ 900 CONTINUE
+ WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
+ & IFLA,IFLB
+ CALL PHO_ABORT
+
+ END
+
+*$ CREATE PHO_ALPHAE.FOR
+*COPY PHO_ALPHAE
+CDECK ID>, PHO_ALPHAE
+ DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
+C**********************************************************************
+C
+C calculation of ALPHA_em
+C
+C input: Q2 scale in GeV**2
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION Q2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ DOUBLE PRECISION PYALEM
+
+ pho_alphae = 1.D0/137.D0
+
+ if(ipamdl(120).eq.1) then
+
+ pho_alphae = PYALEM(Q2)
+
+ endif
+
+ END
+
+*$ CREATE PHO_ALPHAS.FOR
+*COPY PHO_ALPHAS
+CDECK ID>, PHO_ALPHAS
+ DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
+C**********************************************************************
+C
+C calculation of ALPHA_S
+C
+C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
+C 2 lambda_QCD**2 for PDF 2 evolution
+C 3 lambda_QCD**2 for hard scattering
+C Q2 scale in GeV**2
+C
+C initialization needed:
+C IMODE = 0 lambda values taken from PDF table
+C -1 given Q2 is 4-flavour lambda 1
+C -2 given Q2 is 4-flavour lambda 2
+C -3 given Q2 is 4-flavour lambda 3
+C
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION Q2
+ INTEGER IMODE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ INTEGER I
+
+ PHO_ALPHAS = 0.D0
+
+ IF(IMODE.GT.0) THEN
+
+ IF(Q2.LT.PARMDL(148)) THEN
+ NFbeta = 1
+ ELSE IF(Q2.LT.PARMDL(149)) THEN
+ NFbeta = 2
+ ELSE IF(Q2.LT.PARMDL(150)) THEN
+ NFbeta = 3
+ ELSE
+ NFbeta = 4
+ ENDIF
+
+ PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
+ NFbeta = NFbeta+2
+
+ ELSE IF(IMODE.EQ.0) THEN
+
+ DO I=1,3
+ if(I.EQ.3) then
+ ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
+ else
+ ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
+ endif
+ ALQCD2(I,1) = PARMDL(148)
+ & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
+ ALQCD2(I,3) = PARMDL(149)
+ & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
+ ALQCD2(I,4) = PARMDL(150)
+ & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
+
+ ENDDO
+
+ ELSE IF(IMODE.LT.0) THEN
+
+ if(IMODE.eq.-4) then
+ I = 3
+ ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
+ else
+ I = -IMODE
+ ALQCD2(I,2) = Q2
+ endif
+ ALQCD2(I,1) = PARMDL(148)
+ & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
+ ALQCD2(I,3) = PARMDL(149)
+ & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
+ ALQCD2(I,4) = PARMDL(150)
+ & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DFWRAP.FOR
+*COPY PHO_DFWRAP
+CDECK ID>, PHO_DFWRAP
+ SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
+C**********************************************************************
+C
+C wrapper for diffraction dissociation in hadron-nucleus and
+C nucleus-nucleus collisions with DPMJET
+C
+C input: MODE 1: transformation into CMS
+C 2: transformation into Lab
+C JM1/2 indices of old mother particles
+C JM1/2N indices of new mother particles
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER MODE,JM1,JM2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+ DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
+ DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
+
+ INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
+
+C transformation into CMS
+
+ IF(MODE.EQ.1) THEN
+
+ JM1S = JM1
+ JM2S = JM2
+ NHEPS = NHEP
+
+ XM1 = PHEP(5,JM1)
+ XM2 = PHEP(5,JM2)
+
+C boost into CMS
+ P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
+ ECMD = SQRT(SS)
+ DO 10 I=1,4
+ GAMBED(I) = P1(I)/ECMD
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
+ & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ CODD = P1(3)/PTOT1
+ SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = P1(1)/(SIDD*PTOT1)
+ SIFD = P1(2)/(SIDD*PTOT1)
+ ANORF= SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+
+C initial particles in CMS
+
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = ECMD/2.D0*XPSUB
+ P1(4) = P1(3)
+
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -ECMD/2.D0*XTSUB
+ P2(4) = -P2(3)
+
+ CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
+
+ CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
+ & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
+ & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
+
+ CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
+ & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
+ & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
+
+ JM1 = JM1N
+ JM2 = JM2N
+
+C transformation into lab.
+
+ ELSE IF(MODE.EQ.2) THEN
+
+ CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
+ & GAMBED(1),GAMBED(2),GAMBED(3))
+
+ JM1 = JM1S
+ JM2 = JM2S
+
+C clean up after rejection
+
+ ELSE IF(MODE.EQ.-2) THEN
+
+ NHEP = NHEPS
+
+ JM1 = JM1S
+ JM2 = JM2S
+
+ ELSE
+
+ WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DIFDIS.FOR
+*COPY PHO_DIFDIS
+CDECK ID>, PHO_DIFDIS
+ SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
+ & MSOFT,MHARD,IREJ)
+C***********************************************************************
+C
+C sampling of diffractive events of different kinds,
+C (produced particles stored in /POEVT1/)
+C
+C input: IDIF1/2 diffractive process particle 1/2
+C 0 elastic/quasi-elastic scattering
+C 1 diffraction dissociation
+C IMOTH1/2 index of mother particles in /POEVT1/
+C SPROB suppression factor (survival probability) for
+C resolved diffraction dissociation
+C IMODE mode of operation
+C 0 sampling of diffractive cut
+C 1 sampling of enhanced cut
+C 2 sampling of diffractive cut without
+C scattering (needed for double-pomeron)
+C -1 initialization
+C -2 output of statistics
+C
+C output: MSOFT number of generated soft strings
+C MHARD number of generated hard strings
+C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
+C 0 quasi elastic scattering
+C 1 low-mass diffractive dissociation
+C 2 soft high-mass diffractive dissociation
+C 3 hard resolved diffractive dissociation
+C 4 hard direct diffractive dissociation
+C IREJ rejection label
+C 0 successful generation of partons
+C 1 failure
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-7,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
+ DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
+ DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
+ & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
+ & IDIR(2),IPROC(2)
+
+ IF(IMODE.EQ.-1) THEN
+C initialization
+ RETURN
+ ELSE IF(IMODE.EQ.-2) THEN
+C output of statistics
+ RETURN
+ ENDIF
+
+ IREJ = 0
+C mass cuts
+ PIMASS = 0.140D0
+C debug output
+ IF(IDEB(45).GE.10) THEN
+ WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
+ & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
+ & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
+ ENDIF
+ IPAR(1) = IDIF1
+ IPAR(2) = IDIF2
+C save current status
+ MSOFT = 0
+ MHARD = 0
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+ IPOIS3 = IPOIX3
+ JDA11 = JDAHEP(1,IMOTH1)
+ JDA21 = JDAHEP(2,IMOTH1)
+ JDA12 = JDAHEP(1,IMOTH2)
+ JDA22 = JDAHEP(2,IMOTH2)
+ ISTH1 = ISTHEP(IMOTH1)
+ ISTH2 = ISTHEP(IMOTH2)
+ NHEPS = NHEP
+C get mother data
+ NPOSD(1) = IMOTH1
+ NPOSD(2) = IMOTH2
+ DO 20 I=1,2
+ IDPDG(I) = IDHEP(NPOSD(I))
+ IDBAM(I) = IMPART(NPOSD(I))
+ AMP(I) = PHO_PMASS(IDBAM(I),0)
+ IF(IDPDG(I).EQ.22) THEN
+ PMASSD(I) = 0.765D0
+ PVIRTD(I) = PHEP(5,NPOSD(I))**2
+ ELSE
+ PMASSD(I) = PHO_PMASS(IDBAM(I),0)
+ PVIRTD(I) = 0.D0
+ ENDIF
+ 20 CONTINUE
+C get CM system
+ P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
+ P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
+ P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
+ P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
+ SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
+ ECMD = SQRT(SS)
+ IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_DIFDIS: availabe energy',ECMD
+C check total available energy
+ IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
+ & 'PHO_DIFDIS: ',
+ & 'not enough energy for inelastic diffraction',
+ & 'ECM, particle masses:',ECMD,AMP
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+C boost into CMS
+ DO 10 I=1,4
+ GAMBED(I) = P1(I)/ECMD
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
+ & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ CODD = P1(3)/PTOT1
+ SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = P1(1)/(SIDD*PTOT1)
+ SIFD = P1(2)/(SIDD*PTOT1)
+ ANORF= SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C initial particles in CMS
+ PDCMS(1,1) = 0.D0
+ PDCMS(2,1) = 0.D0
+ PDCMS(3,1) = PTOT1
+ PDCMS(4,1) = P1(4)
+ PDCMS(1,2) = 0.D0
+ PDCMS(2,2) = 0.D0
+ PDCMS(3,2) = -PTOT1
+ PDCMS(4,2) = ECMD-P1(4)
+C get new CM momentum
+ AM12 = PMASSD(1)**2
+ AM22 = PMASSD(2)**2
+ PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
+
+C coherence constraint (min/max diffractive mass allowed)
+ IF(IMODE.EQ.2) THEN
+ THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
+ THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
+ THRM2 = SQRT(1-PARMDL(72))*ECMD
+ THRM2 = MIN(THRM2,ECMD/PARMDL(70))
+ ELSE
+ THRM1 = PARMDL(46)
+ THRM2 = PARMDL(45)*ECMD
+C check kinematic limits
+ IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
+ IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
+ ENDIF
+
+C check energy vs. coherence constraints
+ IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
+ IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
+
+C no phase space available
+ IF(IPAR(1)+IPAR(2).EQ.0) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
+ & 'PHO_DIFDIS: ',
+ & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
+ & 'side 1: min. mass, upper mass limit:',
+ & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
+ & 'side 2: min. mass, upper mass limit:',
+ & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ ITRY = 0
+ ITRYM = 10
+ IPARS1 = IPAR(1)
+ IPARS2 = IPAR(2)
+
+C main rejection loop
+C -------------------------------
+ 50 CONTINUE
+ ITRY = ITRY+1
+ IF(ITRY.GT.1) THEN
+ IFAIL(13) = IFAIL(13)+1
+ IF(ITRY.GE.ITRYM) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
+ & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+ IPAR(1) = IPARS1
+ IPAR(2) = IPARS2
+C reset mother-daugther relations
+ NHEP = NHEPS
+ JDAHEP(1,IMOTH1) = JDA11
+ JDAHEP(2,IMOTH1) = JDA21
+ JDAHEP(1,IMOTH2) = JDA12
+ JDAHEP(2,IMOTH2) = JDA22
+ ISTHEP(IMOTH1) = ISTH1
+ ISTHEP(IMOTH2) = ISTH2
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ IPOIX3 = IPOIS3
+C
+ NSLP = 0
+ NCOR = 0
+ 55 CONTINUE
+
+C calculation of kinematics
+ DO 100 I=1,2
+C sampling of masses
+ IRPDG(I) = 0
+ IRBAM(I) = 0
+ IFL1P(I) = IDPDG(I)
+ IFL2P(I) = IDBAM(I)
+ IVEC(I) = 0
+ IDIR(I) = 0
+ ISAM(I) = 0
+ JSAM(I) = 0
+ KSAM(I) = 0
+ IF(IPAR(I).EQ.0) THEN
+C vector meson dominance assumed
+ XMASS(I) = AMP(I)
+ CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
+C diffraction dissociation
+ ELSE IF(IPAR(I).EQ.1) THEN
+ XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
+ PREF2 = PMASSD(I)**2
+ XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
+ CALL PHO_ABORT
+ ENDIF
+ 100 CONTINUE
+
+C sampling of momentum transfer
+ CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
+ & THRM2,TT,SLWGHT,IREJ)
+ IF(IREJ.NE.0) THEN
+ NSLP=NSLP+1
+ IF(NSLP.LT.100) GOTO 55
+ WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
+ & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
+ IREJ = 5
+ RETURN
+ ENDIF
+
+C correct for t-M^2 correlation in diffraction
+ IF(DT_RNDM(TT).GT.SLWGHT) THEN
+ NCOR=NCOR+1
+ IF(NCOR.LT.100) GOTO 55
+ WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
+ & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
+ IREJ = 5
+ RETURN
+ ENDIF
+
+C debug output
+ IF(IDEB(45).GE.5) THEN
+ WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
+ & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
+ ENDIF
+C not double pomeron scattering
+ IF(IMODE.NE.2) THEN
+C sample diffractive interaction processes
+ DO 120 I=1,2
+ IF(IPAR(I).NE.0) THEN
+C find particle combination
+ IF(IDPDG(I).EQ.IFPAP(1)) THEN
+ IP = 2
+ ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
+ IP = 3
+ ELSE IF(IDPDG(I).EQ.990) THEN
+ IP = 4
+ ELSE
+ IP = I+1
+ ENDIF
+C sample dissociation process
+ CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
+ & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
+ & KSAM(I),IDIR(I))
+ IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
+C store process label
+ IF(IDIR(I).GT.0) THEN
+ IPAR(I) = 4
+ ELSE IF(KSAM(I).GT.0) THEN
+ IPAR(I) = 3
+ ELSE IF(ISAM(I).GT.0) THEN
+ IPAR(I) = 2
+ ELSE
+ IPAR(I) = 1
+C mass fine correction
+ CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
+ & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
+ XMASS(I) = XMNEW
+ ENDIF
+ ELSE
+C diffractive pomeron-hadron interaction
+ IPAR(I) = 10+IPROC(I)
+ ENDIF
+C debug output
+ IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
+ & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
+ & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
+ ENDIF
+ 120 CONTINUE
+ ENDIF
+C actualize debug information
+ IF(IMODE.EQ.1) THEN
+ IDIFR1 = IPAR(1)
+ IDIFR2 = IPAR(2)
+ ENDIF
+C calculate new momenta in CMS
+ CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ DO 130 I=1,4
+ PP(I,1) = P1(I)
+ PP(I,2) = P2(I)
+ 130 CONTINUE
+
+C comment line for diffraction
+ CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
+ & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
+C write diffractive strings/particles
+ DO 200 I=1,2
+ I1 = I
+ I2 = 3-I1
+ DO K=1,4
+ PD1(K) = PP(K,I1)
+ PD2(K) = PP(K,I2)
+ ENDDO
+ PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
+ PP(7,I1) = TT
+ IGEN = IPHIST(2,NPOSD(I1))
+ if(IGEN.eq.0) IGEN = -I1*10
+ CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
+ & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(7+I) = IFAIL(7+I)+1
+ IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
+ & I,IPAR(I),XMASS(I)
+ GOTO 50
+ ENDIF
+ ICOLOR(I1,ICPOS) = IPOSP(1,I1)
+ 200 CONTINUE
+C double-pomeron scattering?
+ IF(IMODE.EQ.2) GOTO 150
+
+C diffractive final states
+ DO 300 I=1,2
+ 110 CONTINUE
+ IF(IPAR(I).EQ.0) THEN
+C vector meson production
+ IF(IDPDG(I).EQ.22) THEN
+ IF(ISWMDL(21).GE.0) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
+ ENDIF
+C hadronic state of multi-pomeron coupling
+ ELSE IF(IDPDG(I).EQ.990) THEN
+ CALL PHO_SDECAY(IPOSP(1,I),0,2)
+ ENDIF
+ ELSE
+ IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
+ IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
+ IF(IDIR(I).GT.0) THEN
+ IPAR(I) = 4
+ ELSE IF(KSAM(I).GT.0) THEN
+ IPAR(I) = 3
+ ELSE IF(ISAM(I).GT.0) THEN
+ IPAR(I) = 2
+ ELSE
+ IPAR(I) = 1
+ ENDIF
+ ELSE
+ IPAR(I) = 10+IPROC(I)
+ ENDIF
+ IPHIST(I,ICPOS) = IPAR(I)
+C update debug informantion
+ KSPOM = ISAM(I)
+ KSREG = JSAM(I)
+ KHPOM = KSAM(I)
+ KHDIR = IDIR(I)
+ IDIFR1 = IPAR(1)
+ IDIFR2 = IPAR(2)
+ IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
+
+C resonance decay, pi+pi- background
+ P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
+ P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
+ P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
+ P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
+ CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
+ & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
+C decay
+ IF(IDPDG(I).EQ.22) THEN
+ IPHIST(2,IPOS) = 3
+ IF(ISWMDL(21).GE.0) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(IPOS,ISP,2)
+ ENDIF
+ ELSE
+ CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
+ ENDIF
+ IREJ = 0
+ ELSE
+
+C particle-pomeron scattering
+ IF(IPAR(I).LE.4) THEN
+C non-diffractive particle-pomeron scattering
+ IGEN = IPHIST(2,NPOSD(I))
+ if(IGEN.eq.0) then
+ if(I.eq.1) then
+ IGEN = 5
+ else
+ IGEN = 6
+ endif
+ endif
+ CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
+ & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
+ ELSE
+C diffractive particle-pomeron scattering
+ IPOIX2 = IPOIX2+1
+ IPORES(IPOIX2) = IPROC(I)
+ IPOPOS(1,IPOIX2) = IPOSP(1,I)
+ IPOPOS(2,IPOIX2) = IPOSP(2,I)
+ ENDIF
+ ENDIF
+ ENDIF
+
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IFAIL(20+I) = IFAIL(20+I)+1
+ IF(IPAR(I).GT.1) THEN
+ IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
+ IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
+ IF(IDIR(I).GT.0) THEN
+ IDIR(I) = 0
+ ELSE IF(KSAM(I).GT.0) THEN
+ KSAM(I) = KSAM(I)-1
+ ELSE IF(ISAM(I).GT.0) THEN
+ ISAM(I) = ISAM(I)-1
+ ENDIF
+ GOTO 110
+ ELSE
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
+ & I,IPAR(I),XMASS(I)
+ GOTO 50
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+
+ IDIF1 = IPAR(1)
+ IDIF2 = IPAR(2)
+C update debug information
+ KSPOM = KSPOMS+ISAM(1)+ISAM(2)
+ KSREG = KSREGS+JSAM(1)+JSAM(2)
+ KHPOM = KHPOMS+KSAM(1)+KSAM(2)
+ KHDIR = KHDIRS+IDIR(1)+IDIR(2)
+
+ 150 CONTINUE
+
+C debug output
+ IF(IDEB(45).GE.10) THEN
+ WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
+ & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
+ & IPAR,NPOSD,MSOFT,MHARD,IMODE
+ ENDIF
+ IF(IDEB(45).GE.15) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
+ & '------------------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DIFPRO.FOR
+*COPY PHO_DIFPRO
+CDECK ID>, PHO_DIFPRO
+ SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
+ & IPROC,ISAM,JSAM,KSAM,IDIR)
+C*********************************************************************
+C
+C sampling of diffraction dissociation process
+C
+C input: IP particle combination
+C ICUT user imposed limitations
+C ID1/2 PDG particle code of scattering particles
+C XMASS diffractively produced mass (GeV)
+C P2V1/2 virtuality of scattering particles (Gev**2)
+C SPROB suppression factor for resolved single and
+C double diffraction dissociation
+C
+C output: IRPOC process ID
+C ISAM number of cut pomerons (soft)
+C JSAM number of cut reggeons
+C KSAM number of cut pomerons (hard)
+C IDIR direct hard interaction
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ ISAM = 0
+ JSAM = 0
+ KSAM = 0
+ IDIR = 0
+
+ IF(XMASS.GT.3.D0) THEN
+C rapidity gap survival probability
+ SPRO = 1.D0
+ IF(ISWMDL(28).GE.1) SPRO = SPROB
+C sample interaction
+ IPROC = 0
+ CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
+ ELSE
+ IPROC = 1
+ ENDIF
+ IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
+C non-diffractive hadron-pomeron interaction
+ IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
+C option for suppression of multiple interaction
+ IF(ICUT.EQ.0) THEN
+ IPROC = 1
+ IF(ISAM+KSAM+IDIR.GT.0) THEN
+ ISAM = 1
+ JSAM = 0
+ ELSE
+ JSAM = 1
+ ENDIF
+ KSAM = 0
+ IDIR = 0
+ ELSE IF(ICUT.EQ.1) THEN
+ IF(IDIR.GT.0) THEN
+ ELSE IF(KSAM.GT.0) THEN
+ KSAM = 1
+ ISAM = 0
+ JSAM = 0
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = 1
+ JSAM = 0
+ ELSE
+ JSAM = 1
+ ENDIF
+ ELSE IF(ICUT.EQ.2) THEN
+ KSAM = MIN(KSAM,1)
+ ELSE IF(ICUT.EQ.3) THEN
+ ISAM = MIN(ISAM,1)
+ ENDIF
+ ENDIF
+ END
+
+*$ CREATE PHO_DIFPAR.FOR
+*COPY PHO_DIFPAR
+CDECK ID>, PHO_DIFPAR
+ SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
+ & IPOSH1,IPOSH2,IMODE,IREJ)
+C***********************************************************************
+C
+C perform string construction for diffraction dissociation
+C
+C input: IMOTH1,2 index of mother particles in POEVT1
+C IGENM production process of mother particles
+C IFL1,IFL2 particle numbers
+C (IDPDG,IDBAM for quasi-elas. hadron)
+C IPAR 0 quasi-elasic scattering
+C 1 single string configuration
+C 2 two string configuration
+C P1 massive 4 momentum of first
+C P1(6) virtuality/squ.mass of particle (GeV**2)
+C P1(7) virtuality of Pomeron (neg, GeV**2)
+C P2 massive 4 momentum of second particle
+C IMODE 1 diffraction dissociation
+C 2 double-pomeron scattering
+C
+C output: IPOSH1,2 index of the particles in /POEVT1/
+C IREJ 0 successful string construction
+C 1 no string construction possible
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(7),P2(7)
+
+ PARAMETER ( EPS = 1.D-7,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DIMENSION PCH1(2,4)
+ data IC1 /0/
+ data IC2 /0/
+
+ IREJ = 0
+ ILTR1 = NHEP+1
+ IGEN = IGENM
+ if(IGENM.le.-10) IGEN = 0
+
+C elastic part
+ IF(IPAR.EQ.0) THEN
+ IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
+ if(IGEN.eq.0) IGEN = 3
+C pi+/pi- isotropic background
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
+ & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
+ CALL PHO_SDECAY(IPOSH1,0,-2)
+ ELSE
+ if(IGEN.eq.0) then
+ IGEN = 2
+ if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
+ endif
+C registration of particle or resonance
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
+ & P1(4),0,IGEN,0,0,IPOSH1,1)
+ ENDIF
+
+C diffraction dissociation
+ ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
+C calculation of resulting particle momenta
+ IF(IMOTH1.EQ.NPOSD(1)) THEN
+ K = 2
+ ELSE
+ K = 1
+ ENDIF
+ DO 100 I=1,4
+ PCH1(2,I) = PDCMS(I,K)-P2(I)
+ PCH1(1,I) = P1(I)-PCH1(2,I)
+ 100 CONTINUE
+
+C registration
+ if(IMODE.LT.2) then
+ if(IGEN.eq.0) IGEN = -IGENM/10+4
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
+ & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
+ else
+ if(IGEN.eq.0) IGEN = 4
+ endif
+ CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
+ & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
+
+C invalid IPAR
+ ELSE
+ WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+C back transformation
+ CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
+ & GAMBED(1),GAMBED(2),GAMBED(3))
+
+ END
+
+*$ CREATE PHO_QELAST.FOR
+*COPY PHO_QELAST
+CDECK ID>, PHO_QELAST
+ SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
+C**********************************************************************
+C
+C sampling of quasi elastic processes
+C
+C input: IPROC 2 purely elastic scattering
+C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
+C IPROC 4 double pomeron scattering
+C IPROC -1 initialization
+C IPROC -2 output of statistics
+C JM1/2 index of initial particle 1/2
+C
+C output: initial and final particles in /POEVT1/ involving
+C polarized resonances in /POEVT1/ and decay
+C products
+C
+C IREJ 0 successful
+C 1 failure
+C 50 user rejection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( NTAB = 20,
+ & EPS = 1.D-10,
+ & PIMASS = 0.13D0,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
+ DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
+ DIMENSION IFL(2),IDPRO(4)
+ character*15 pho_pname
+ CHARACTER*8 VMESA(0:4),VMESB(0:4)
+ DIMENSION ISAMVM(4,4)
+ DATA IDPRO / 113,223,333,92 /
+ DATA VMESA / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+ DATA VMESB / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+
+C sampling of elastic/quasi-elastic processes
+ IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
+ IREJ = 0
+ NPOSD(1) = JM1
+ NPOSD(2) = JM2
+ DO 55 I=1,2
+ PMI(I) = PHEP(5,NPOSD(I))
+ IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
+ 55 CONTINUE
+C get CM system
+ PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
+ ECMD = SQRT(SS)
+
+ IF(ECMD.LE.PMI(1)+PMI(2)) THEN
+ IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
+ & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
+ & ECMD,PMI
+ IREJ = 5
+ RETURN
+ ENDIF
+
+ DO 60 I=1,4
+ GAMBED(I) = PK1(I)/ECMD
+ 60 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
+ & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
+C rotation angles
+ CODD = PK1(3)/PTOT1
+ SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = PK1(1)/(SIDD*PTOT1)
+ SIFD = PK1(2)/(SIDD*PTOT1)
+ ANORF = SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C get CM momentum
+ AM12 = PMI(1)**2
+ AM22 = PMI(2)**2
+ PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
+
+C production process of mother particles
+ IGEN = IPHIST(2,NPOSD(1))
+ if(IGEN.eq.0) IGEN = IPROC
+
+ ICALL = ICALL + 1
+C main rejection label
+ 50 CONTINUE
+C determine process and final particles
+ IFL(1) = IDHEP(NPOSD(1))
+ IFL(2) = IDHEP(NPOSD(2))
+ IF(IPROC.EQ.3) THEN
+ ITRY = 0
+ 100 CONTINUE
+ ITRY = ITRY+1
+ IF(ITRY.GT.50) THEN
+ IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
+ & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
+ & ITRY,ECMD
+ IREJ = 5
+ RETURN
+ ENDIF
+ XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
+ DO 110 I=1,4
+ DO 120 J=1,4
+ XI = XI-SIGVM(I,J)
+ IF(XI.LE.0.D0) GOTO 130
+ 120 CONTINUE
+ 110 CONTINUE
+ 130 CONTINUE
+ IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
+ IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
+ ISAMVM(I,J) = ISAMVM(I,J)+1
+ ISAMQE = ISAMQE+1
+C sample new masses
+ CALL PHO_SAMASS(IFL(1),RMASS(1))
+ CALL PHO_SAMASS(IFL(2),RMASS(2))
+ IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
+ ELSE IF(IPROC.EQ.2) THEN
+ I = 0
+ J = 0
+ ISAMEL = ISAMEL+1
+ RMASS(1) = PHO_PMASS(NPOSD(1),2)
+ RMASS(2) = PHO_PMASS(NPOSD(2),2)
+ ELSE
+ WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
+ CALL PHO_ABORT
+ ENDIF
+C sample momentum transfer
+ CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
+ & SLWGHT,IREJ)
+ IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
+ & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
+C calculate new momenta
+ CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ DO K=1,4
+ P(K,1) = PK1(K)
+ P(K,2) = PK2(K)
+ ENDDO
+C comment line for elastic/quasi-elastic scattering
+ CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
+ & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
+
+ I1 = NHEP+1
+C fill /POEVT1/
+ DO 200 I=1,2
+ K = 3-I
+ IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
+C pi+/pi- isotropic background
+ IGEN = 3
+ CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
+ & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
+ ICOLOR(I,ICPOS) = IPOS
+ CALL PHO_SDECAY(IPOS,0,-2)
+ ELSE
+C registration
+ IGEN = 2
+ if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
+ CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
+ & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
+ ICOLOR(I,ICPOS) = IPOS
+ ENDIF
+ 200 CONTINUE
+ I2 = NHEP
+C search for vector mesons
+ DO 300 I=I1,I2
+C decay according to polarization
+ IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(I,ISP,2)
+ ENDIF
+ 300 CONTINUE
+ I2 = NHEP
+C back transformation
+ CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
+ & GAMBED(2),GAMBED(3))
+
+C initialization of tables
+ ELSE IF(IPROC.EQ.-1) THEN
+ DO 10 I=1,4
+ DO 20 J=1,4
+ ISAMVM(I,J) = 0
+ 20 CONTINUE
+ 10 CONTINUE
+ ISAMEL = 0
+ ISAMQE = 0
+ IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
+ IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
+ CALL PHO_SAMASS(-1,RMASS(1))
+ ICALL = 0
+
+C output of statistics
+ ELSE IF(IPROC.EQ.-2) THEN
+ IF(ICALL.LT.10) RETURN
+ WRITE(LO,'(/,1X,A,I10/,1X,A)')
+ & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
+ & '---------------------------------------------------'
+ WRITE(LO,'(1X,A,I10)')
+ & 'sampled elastic processes:',ISAMEL
+ WRITE(LO,'(1X,A,I10)')
+ & 'sampled quasi-elastic vectormeson production:',ISAMQE
+ WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
+ DO 30 I=1,4
+ WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
+ 30 CONTINUE
+ CALL PHO_SAMASS(-2,RMASS(1))
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
+ & 'unknown process ID',IPROC
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_CDIFF.FOR
+*COPY PHO_CDIFF
+CDECK ID>, PHO_CDIFF
+ SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
+C**********************************************************************
+C
+C preparation of /POEVT1/ for double-pomeron scattering
+C
+C input: IMOTH1/2 index of mother particles in /POEVT1/
+C
+C IMODE 1 sampling of pomeron-pomeron scattering
+C -1 initialization
+C -2 output of statistics
+C
+C output: MSOFT number of generated soft strings
+C MHARD number of generated hard strings
+C IREJ 0 accepted
+C 1 rejected
+C 50 user rejection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DIMENSION PD(4)
+
+ if(IMODE.ne.1) return
+
+ IREJ = 0
+ IP = 4
+C select first diffraction
+ IF(DT_RNDM(DUM).GT.0.5D0) THEN
+ IPAR1 = 1
+ IPAR2 = 0
+ ELSE
+ IPAR1 = 0
+ IPAR2 = 1
+ ENDIF
+ ITRY2 = 0
+ ITRYM = 1000
+
+C save current status
+ MSOFT = 0
+ MHARD = 0
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+ IPOIS3 = IPOIX3
+ JDA11 = JDAHEP(1,IMOTH1)
+ JDA21 = JDAHEP(2,IMOTH1)
+ JDA12 = JDAHEP(1,IMOTH2)
+ JDA22 = JDAHEP(2,IMOTH2)
+ ISTH1 = ISTHEP(IMOTH1)
+ ISTH2 = ISTHEP(IMOTH2)
+ NHEPS = NHEP
+
+C find mother particle production process
+ IGEN = IPHIST(2,IMOTH1)
+ if(IGEN.eq.0) IGEN = 4
+
+C main generation loop
+ 60 CONTINUE
+
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+ I1 = IPAR1
+ I2 = IPAR2
+C reset mother-daugther relations
+ NHEP = NHEPS
+ JDAHEP(1,IMOTH1) = JDA11
+ JDAHEP(2,IMOTH1) = JDA21
+ JDAHEP(1,IMOTH2) = JDA12
+ JDAHEP(2,IMOTH2) = JDA22
+ ISTHEP(IMOTH1) = ISTH1
+ ISTHEP(IMOTH2) = ISTH2
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ IPOIX3 = IPOIS3
+C rejection counter
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) THEN
+ IFAIL(39) = IFAIL(39)+1
+ IF(ITRY2.GE.ITRYM) GOTO 50
+ ENDIF
+C generate two diffractive events
+ CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+C mass of pomeron-pomeron system
+ DO 100 I2 = NHEP,1,-1
+ IF(IDHEP(I2).EQ.990) GOTO 110
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 I1 = I2-1,1,-1
+ IF(IDHEP(I1).EQ.990) GOTO 130
+ 120 CONTINUE
+ 130 CONTINUE
+ DO 140 I=1,4
+ PD(I) = PHEP(I,I1)+PHEP(I,I2)
+ 140 CONTINUE
+ XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
+ IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
+ & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
+ IF(XMASS.LT.0.1D0) GOTO 60
+ XMASS = SQRT(XMASS)
+ IF(XMASS.LT.PARMDL(71)) GOTO 60
+
+C sample pomeron-pomeron interaction process
+ CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
+ & IPROC,ISAM,JSAM,KSAM,IDIR)
+
+C non-diffractive pomeron-pomeron interactions
+ IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
+ 200 CONTINUE
+ IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
+C debug output
+ IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
+ & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
+ & IP,XMASS,ISAM,JSAM,KSAM,IDIR
+C store debug information
+ IF(IDIR.GT.0) THEN
+ IPAR = 4
+ ELSE IF(KSAM.GT.0) THEN
+ IPAR = 3
+ ELSE IF(ISAM.GT.0) THEN
+ IPAR = 2
+ ELSE
+ IPAR = 1
+ ENDIF
+ IDDPOM = IPAR
+ IF(ISAM+JSAM.GT.0) KSDPO = 1
+ IF(KSAM+IDIR.GT.0) KHDPO = 1
+ KSPOM = ISAM
+ KSREG = JSAM
+ KHPOM = KSAM
+ KHDIR = IDIR
+ KSTRG = 0
+ KSLOO = 0
+C generate pomeron-pomeron interaction
+ CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(3) = IFAIL(3)+1
+ IF(IPAR.GT.1) THEN
+ IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
+ IF(IDIR.GT.0) THEN
+ IFAIL(10) = IFAIL(10)+1
+ IDIR = 0
+ ELSE IF(KSAM.GT.0) THEN
+ KSAM = KSAM-1
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ ENDIF
+ GOTO 200
+ ELSE
+ IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
+ & I,IPAR,XMASS
+ GOTO 50
+ ENDIF
+ ENDIF
+
+C diffractive pomeron-pomeron interactions
+ ELSE
+ IPOIX2 = IPOIX2+1
+ IPORES(IPOIX2) = IPROC
+ IPOPOS(1,IPOIX2) = I1
+ IPOPOS(2,IPOIX2) = I2
+ IPAR = 10+IPROC
+ IDDPOM = IPAR
+ ENDIF
+
+C update debug information
+ KSPOM = KSPOMS+ISAM
+ KSREG = KSREGS+JSAM
+ KHPOM = KHPOMS+KSAM
+ KHDIR = KHDIRS+IDIR
+C comment line for central diffraction
+ CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
+ & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
+ PHEP(5,IPOS) = XMASS
+C debug output
+ IF(IDEB(59).GE.15) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
+ & '-----------------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+
+C treatment of rejection
+ 50 CONTINUE
+ IREJ = 1
+ IFAIL(40) = IFAIL(40)+1
+ IF(IDEB(59).GE.3) THEN
+ WRITE(LO,'(1X,A)')
+ & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
+ IF(IDEB(59).GE.10) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SAMASS.FOR
+*COPY PHO_SAMASS
+CDECK ID>, PHO_SAMASS
+ SUBROUTINE PHO_SAMASS(IFLA,RMASS)
+C**********************************************************************
+C
+C resonance mass sampling of quasi elastic processes
+C
+C input: IFLA PDG number of particle
+C IFLA -1 initialization
+C IFLA -2 output of statistics
+C
+C output: RMASS particle mass (in GeV)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+
+ PARAMETER(NTABM=50)
+ DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
+ DIMENSION SUM(4),ICALL(4)
+
+C*****************************************************************
+C initialization of tables
+ IF(IFLA.EQ.-1) THEN
+C
+ NSTEP = NTABM
+ DO 102 I=1,4
+ ICALL(I) = 0
+
+ DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
+ DO 105 K=1,NSTEP
+ RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
+ 105 CONTINUE
+ 102 CONTINUE
+C calculate table of dsig/dm
+ CALL PHO_DSIGDM(RMA,XMA,NSTEP)
+C output of table
+ IF(IDEB(35).GE.1) THEN
+ WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
+ WRITE(LO,'(1X,A,/1X,A)')
+ & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
+ & ' -------------------------------------------------------'
+ DO 106 K=1,NSTEP
+ WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
+ & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
+ 106 CONTINUE
+ ENDIF
+C make second table for sampling
+ DO 109 I=1,4
+ SUM(I) = 0.D0
+ DO 108 K=2,NSTEP
+ SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
+ XMC(I,K) = SUM(I)
+ 108 CONTINUE
+ 109 CONTINUE
+C normalization
+ DO 118 K=1,NSTEP
+ DO 119 I=1,4
+ XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
+ 119 CONTINUE
+ 118 CONTINUE
+ IF(IDEB(35).GE.10) THEN
+ WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
+ WRITE(LO,'(1X,A,/1X,A)')
+ & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
+ & ' -------------------------------------------------------'
+ DO 120 K=1,NSTEP
+ WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
+ & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
+ 120 CONTINUE
+ ENDIF
+C
+C**************************************************
+C output of statistics
+ ELSE IF(IFLA.EQ.-2) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
+ & '----------------------'
+ WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
+ & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
+
+C
+C********************************************************
+C sampling of RMASS
+ ELSE
+C quasi-elastic vector meson production
+ IF(IFLA.EQ.113) THEN
+ KP = 1
+ ELSE IF(IFLA.EQ.223) THEN
+ KP = 2
+ ELSE IF(IFLA.EQ.333) THEN
+ KP = 3
+ ELSE IF(IFLA.EQ.92) THEN
+ KP = 4
+C quasi-elastic production of h*
+ ELSE IF(IFLA.EQ.91) THEN
+ RMASS = 0.35D0
+ RETURN
+C elastic hadron scattering
+ ELSE
+ RMASS = PHO_PMASS(IFLA,1)
+ IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
+ & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
+ RETURN
+ ENDIF
+C
+C sample mass of vector mesonsn / two-pi background
+ XI = DT_RNDM(RMASS) + EPS
+C binary search
+ IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
+ KMIN=1
+ KMAX=NSTEP
+ 300 CONTINUE
+ IF((KMAX-KMIN).EQ.1) GOTO 400
+ KK=(KMAX+KMIN)/2
+ IF(XI.LE.XMC(KP,KK)) THEN
+ KMAX=KK
+ ELSE
+ KMIN=KK
+ ENDIF
+ GOTO 300
+ 400 CONTINUE
+ ELSE
+ WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
+ WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
+ & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
+ CALL PHO_ABORT
+ ENDIF
+C fine interpolation
+ RMASS = RMA(KP,KMIN)+
+ & (RMA(KP,KMAX)-RMA(KP,KMIN))/
+ & (XMC(KP,KMAX)-XMC(KP,KMIN))
+ & *(XI-XMC(KP,KMIN))
+ IF(IDEB(35).GE.20) THEN
+ IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
+ & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
+ & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
+ WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
+ & IFLA,RMASS
+ ENDIF
+ ICALL(KP) = ICALL(KP)+1
+
+ ENDIF
+ END
+
+*$ CREATE PHO_DSIGDM.FOR
+*COPY PHO_DSIGDM
+CDECK ID>, PHO_DSIGDM
+ SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
+C**********************************************************************
+C
+C differential cross section DSIG/DM of low mass enhancement
+C
+C input: RMA(4,NTABM) mass values
+C output: XMA(4,NTABM) DSIG/DM of resonances
+C 1 rho production
+C 2 omega production
+C 3 phi production
+C 4 pi-pi continuum
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10 )
+
+ PARAMETER(NTABM=50)
+ DIMENSION XMA(4,NTABM),RMA(4,NTABM)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+
+ PIMASS = 0.135
+C rho meson shape (mass dependent width)
+ QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
+ DO 100 I=1,NSTEP
+ XMASS = RMA(1,I)
+ QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
+ GAMMA = GAMM(1)*(QQ/QRES)**3
+ XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
+ & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
+ 100 CONTINUE
+C omega/phi meson (constant width)
+ DO 200 K=2,3
+ DO 300 I=1,NSTEP
+ XMASS = RMA(K,I)
+ XMA(K,I) = XMASS*GAMM(K)
+ & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
+ 300 CONTINUE
+ 200 CONTINUE
+C pi-pi continuum
+ DO 400 I=1,NSTEP
+ XMASS = RMA(4,I)
+ XMA(4,I) = (XMASS-0.29D0)**2/XMASS
+ 400 CONTINUE
+
+ END
+
+*$ CREATE PHO_SDECAY.FOR
+*COPY PHO_SDECAY
+CDECK ID>, PHO_SDECAY
+ SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
+C**********************************************************************
+C
+C decay of single resonance of /POEVT1/:
+C decay in helicity frame according to polarization, isotropic
+C decay and decay with limited transverse phase space possible
+C
+C ATTENTION:
+C reference to particle number of CPC has to exist
+C
+C input: NPOS position in /POEVT1/
+C ISP 0 decay according to phase space
+C 1 decay according to transversal polarization
+C 2 decay according to longitudinal polarization
+C 3 decay with limited phase space
+C ILEV decay mode to use
+C 1 strong only
+C 2 strong and ew of tau, charm, and bottom
+C 3 strong and electro-weak decays
+C negative: remove mother resonance after decay
+C
+C output: /POEVT1/,/POEVT2/ final particles according to decay mode
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-15,
+ & DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ DIMENSION WGHD(20),KCH(20),ID(3)
+
+ IMODE = ABS(ILEV)
+ IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
+
+C comment entry
+ IF(ISTHEP(NPOS).GT.11) RETURN
+
+C particle stable?
+ IDcpc = IMPART(NPOS)
+ IF(IDcpc.EQ.0) return
+ IDabs = iabs(IDcpc)
+ if(idec_list(1,IDabs).eq.0) return
+
+C different decay modi (times)
+ IF(IMODE.EQ.1) THEN
+ if(idec_list(1,IDabs).ne.1) return
+ ELSE IF(IMODE.EQ.2) THEN
+ if(idec_list(1,IDabs).gt.2) return
+ ELSE IF(IMODE.EQ.3) THEN
+ if(idec_list(1,IDabs).gt.3) return
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
+ CALL PHO_ABORT
+ ENDIF
+
+C decay products, check for mass limitations
+ K = 0
+ WGSUM = 0.D0
+ AMIST = PHEP(5,NPOS)
+ DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
+ AMSUM = 0.D0
+ DO 200 L=1,3
+ ID(L) = isec_list(L,I)
+ IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
+ 200 CONTINUE
+ IF(AMSUM.LT.AMIST) THEN
+ K = K+1
+ WGHD(K) = wg_sec_list(I)
+ KCH(K) = I
+ ENDIF
+ 100 CONTINUE
+ IF(K.EQ.0)THEN
+ WRITE(LO,'(/1X,A,I6,3E12.4)')
+ & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
+ & NPOS,AMIST,AMSUM
+ CALL PHO_PREVNT(0)
+ RETURN
+ ENDIF
+
+C sample new decay channel
+ XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
+ K = 0
+ WGSUM = 0.D0
+ 500 CONTINUE
+ K = K+1
+ WGSUM = WGSUM+WGHD(K)
+ IF(XI.GT.WGSUM) GOTO 500
+ IK = KCH(K)
+ ID(1) = isec_list(1,IK)
+ ID(2) = isec_list(2,IK)
+ ID(3) = isec_list(3,IK)
+ if(IDcpc.lt.0) then
+ ID(1) = ipho_anti(ID(1))
+ ID(2) = ipho_anti(ID(2))
+ if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
+ endif
+
+C rotation
+ PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
+ CXS = PHEP(1,NPOS)/PTOT
+ CYS = PHEP(2,NPOS)/PTOT
+ CZS = PHEP(3,NPOS)/PTOT
+C boost
+ GBET = PTOT/AMIST
+ GAM = PHEP(4,NPOS)/AMIST
+
+ IF(ID(3).EQ.0) THEN
+C two particle decay
+ CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
+ ELSE
+C three particle decay
+ CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
+ & pho_pmass(ID(3),0),ISP)
+ ENDIF
+
+ IF(ILEV.LT.0) THEN
+ IF(NHEP.NE.NPOS) THEN
+ WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
+ & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
+ CALL PHO_ABORT
+ ENDIF
+ IMO1 = JMOHEP(1,NPOS)
+ IMO2 = JMOHEP(2,NPOS)
+ NHEP = NHEP-1
+ ELSE
+ IMO1 = NPOS
+ IMO2 = 0
+ ENDIF
+ IPH1 = IPHIST(1,NPOS)
+ IPH2 = IPHIST(2,NPOS)
+
+C back transformation and registration
+ DO 300 I=1,3
+ IF(ID(I).NE.0) THEN
+ CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
+ & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
+ XX = PTOT*CX
+ YY = PTOT*CY
+ ZZ = PTOT*CZ
+ CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
+ & IPH1,IPH2,0,0,IPOS,1)
+ ENDIF
+ 300 CONTINUE
+
+ 400 CONTINUE
+C debug output
+ IF(IDEB(36).GE.20) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
+ & '--------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_SDECY2.FOR
+*COPY PHO_SDECY2
+CDECK ID>, PHO_SDECY2
+ SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
+C**********************************************************************
+C
+C isotropic/anisotropic two particle decay in CM system,
+C (transversely/longitudinally polarized boson into two
+C pseudo-scalar mesons)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ UMO2=UMO*UMO
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
+ ECM(2)=UMO-ECM(1)
+ WAU=ECM(1)*ECM(1)-AM11
+ IF(WAU.LT.0.D0) THEN
+ WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
+ CALL PHO_ABORT
+ ENDIF
+ PCM(1)=SQRT(WAU)
+ PCM(2)=PCM(1)
+
+ CALL PHO_SFECFE(SIF(1),COF(1))
+ IF(ISP.EQ.0) THEN
+C no polarization
+ COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
+ ELSE IF(ISP.EQ.1) THEN
+C transverse polarization
+ 400 CONTINUE
+ COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
+ SID12 = 1.D0-COD(1)*COD(1)
+ IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
+ ELSE IF(ISP.EQ.2) THEN
+C longitudinal polarization
+ 500 CONTINUE
+ COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
+ COD12 = COD(1)*COD(1)
+ IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
+ & 'invalid polarization',ISP
+ CALL PHO_ABORT
+ ENDIF
+
+ COD(2) = -COD(1)
+ COF(2) = -COF(1)
+ SIF(2) = -SIF(1)
+
+ END
+
+*$ CREATE PHO_SDECY3.FOR
+*COPY PHO_SDECY3
+CDECK ID>, PHO_SDECY3
+ SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
+C**********************************************************************
+C
+C isotropic/anisotropic three particle decay in CM system,
+C (transversely/longitudinally polarized boson into three
+C pseudo-scalar mesons)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-30,
+ & EPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ DIMENSION F(5),XX(5)
+
+C calculation of maximum of S2 phase space weight
+ UMOO=UMO+UMO
+ GU=(AM2+AM3)**2
+ GO=(UMO-AM1)**2
+ UFAK=1.0000000000001D0
+ IF (GU.GT.GO) UFAK=0.99999999999999D0
+ OFAK=2.D0-UFAK
+ GU=GU*UFAK
+ GO=GO*OFAK
+ DS2=(GO-GU)/99.D0
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ AM33=AM3*AM3
+ UMO2=UMO*UMO
+ RHO2=0.D0
+ S22=GU
+ DO 124 I=1,100
+ S21=S22
+ S22=GU+(I-1.D0)*DS2
+ RHO1=RHO2
+ RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
+ IF(RHO2.LT.RHO1) GOTO 125
+ 124 CONTINUE
+
+ 125 CONTINUE
+ S2SUP=(S22-S21)/2.D0+S21
+ SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
+ & /(S2SUP+EPS)
+ SUPRHO=SUPRHO*1.05D0
+ XO=S21-DS2
+ IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
+ IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
+ XX(1)=XO
+ XX(3)=S22
+ X1=(XO+S22)*0.5D0
+ XX(2)=X1
+ F(3)=RHO2
+ F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
+ F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
+ DO 126 I=1,16
+ X4=(XX(1)+XX(2))*0.5D0
+ X5=(XX(2)+XX(3))*0.5D0
+ F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
+ F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
+ XX(4)=X4
+ XX(5)=X5
+ DO 128 II=1,5
+ IA=II
+ DO 131 III=IA,5
+ IF(F(II).LT.F(III)) THEN
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+ ENDIF
+ 131 CONTINUE
+ 128 CONTINUE
+ SUPRHO=F(1)
+ S2SUP=XX(1)
+ DO 129 II=1,3
+ IA=II
+ DO 130 III=IA,3
+ IF (XX(II).LT.XX(III)) THEN
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+ ENDIF
+ 130 CONTINUE
+ 129 CONTINUE
+ 126 CONTINUE
+
+ AM23=(AM2+AM3)**2
+
+C selection of S1
+ ITH=0
+ 200 CONTINUE
+ ITH=ITH+1
+ IF(ITH.GT.200) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_SDECY3:ERROR: too many iterations',ITH
+ CALL PHO_ABORT
+ ENDIF
+ S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
+ Y=DT_RNDM(AM23)*SUPRHO
+ RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
+ IF(Y.GT.RHO) GOTO 200
+
+C selection of S2
+ S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
+ & /(2.D0*S2)-RHO/2.D0
+ S3=UMO2+AM11+AM22+AM33-S1-S2
+ ECM(1)=(UMO2+AM11-S2)/UMOO
+ ECM(2)=(UMO2+AM22-S3)/UMOO
+ ECM(3)=(UMO2+AM33-S1)/UMOO
+ PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
+ PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
+ PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
+
+C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
+ IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
+ COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
+ ELSE
+ COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
+ ENDIF
+ COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
+ & /(2.D0*PCM(2)*PCM(3))
+ SINTH2=SQRT(1.D0-COSTH2*COSTH2)
+ SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
+ COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
+
+C selection of the sperical coordinates of particle 3
+ CALL PHO_SFECFE(SIF(3),COF(3))
+ IF(ISP.EQ.0) THEN
+C no polarization
+ COD(3) = 2.D0*DT_RNDM(S2)-1.D0
+ ELSE IF(ISP.EQ.1) THEN
+C transverse polarization
+ 400 CONTINUE
+ COD(3) = 2.D0*DT_RNDM(S1)-1.D0
+ SID32 = 1.D0-COD(3)*COD(3)
+ IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
+ ELSE IF(ISP.EQ.2) THEN
+C longitudinal polarization
+ 500 CONTINUE
+ COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
+ COD32 = COD(3)*COD(3)
+ IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
+ & 'invalid polarization',ISP
+ CALL PHO_ABORT
+ ENDIF
+
+C selection of the rotation angle of p1-p2 plane along p3
+ IF(ISP.EQ.0) THEN
+ CALL PHO_SFECFE(SFE,CFE)
+ ELSE
+ SFE = 0.D0
+ CFE = 1.D0
+ ENDIF
+ CX11=-COSTH1
+ CY11=SINTH1*CFE
+ CZ11=SINTH1*SFE
+ CX22=-COSTH2
+ CY22=-SINTH2*CFE
+ CZ22=-SINTH2*SFE
+
+ SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
+ COD(1)=CX11*COD(3)+CZ11*SID3
+ IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
+ WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
+ & COD(1),COF(3),SID3,CX11,CZ11
+ CALL PHO_PREVNT(-1)
+ ENDIF
+
+ SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
+ COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
+ SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
+ COD(2)=CX22*COD(3)+CZ22*SID3
+ SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
+ COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
+ SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
+
+ END
+
+*$ CREATE PHO_DFMASS.FOR
+*COPY PHO_DFMASS
+CDECK ID>, PHO_DFMASS
+ DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
+C**********************************************************************
+C
+C sampling of Mx diffractive mass distribution within
+C limits XMIN, XMAX
+C
+C input: XMIN,XMAX mass limitations (GeV)
+C PREF2 original particle mass/ reference mass
+C (squared, GeV**2)
+C PVIRT2 particle virtuality
+C IMODE M**2 mass distribution
+C 1 1/(M**2+Q**2)
+C 2 1/(M**2+Q**2)**alpha
+C -1 1/(M**2-Mref**2+Q**2)
+C -2 1/(M**2-Mref**2+Q**2)**alpha
+C
+C output: diffractive mass (GeV)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
+ WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
+ & 'invalid mass limits',XMIN,XMAX,PREF2
+ CALL PHO_PREVNT(-1)
+ PHO_DFMASS = 0.135D0
+ RETURN
+ ENDIF
+
+ IF(IMODE.GT.0) THEN
+ PM2 = -PVIRT2
+ ELSE
+ PM2 = PREF2 - PVIRT2
+ ENDIF
+
+C critical pomeron
+ IF(ABS(IMODE).EQ.1) THEN
+ XMIN2 = LOG(XMIN**2-PM2)
+ XMAX2 = LOG(XMAX**2-PM2)
+ XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
+ XMA2 = EXP(XI)+PM2
+
+C supercritical pomeron
+ ELSE IF(ABS(IMODE).EQ.2) THEN
+ DDELTA = 1.D0-PARMDL(48)
+ XMIN2 = (XMIN**2-PM2)**DDELTA
+ XMAX2 = (XMAX**2-PM2)**DDELTA
+ XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
+ XMA2 = XI**(1.D0/DDELTA)+PM2
+ ELSE
+ WRITE(LO,'(/,1X,A,I3)')
+ & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ PHO_DFMASS = SQRT(XMA2)
+C debug output
+ IF(IDEB(43).GE.15) THEN
+ WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
+ & XMIN,XMAX,PREF2,SQRT(XMA2)
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DIFSLP.FOR
+*COPY PHO_DIFSLP
+CDECK ID>, PHO_DIFSLP
+ SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
+ & TT,SLWGHT,IREJ)
+C**********************************************************************
+C
+C sampling of T (Mandelstam variable) distribution within
+C certain limits TMIN, TMAX
+C
+C input: IDF1,2 type of diffractive vertex
+C 0 elastic/quasi-elastic scattering
+C 1 diffraction dissociation
+C IVEC1,2 vector meson IDs in case of quasi-elastic
+C scattering, otherwise 0
+C XM1 mass of diffractive system 1 (GeV)
+C XM2 mass of diffractive system 2 (GeV)
+C XMX max. mass of diffractive system (GeV)
+C
+C output: TT squared momentum transfer ( < 0, GeV**2)
+C SLWGHT weight to allow for mass-dependent slope
+C IREJ 0 successful sampling
+C 1 masses too big for given T range
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IREJ = 0
+ XM12 = XM1**2
+ XM22 = XM2**2
+ SS = ECMD**2
+C
+C range of momentum transfer t
+ TMIN = -PARMDL(68)
+ TMAX = -PARMDL(69)
+C determine min. abs(t) necessary to produce masses
+ PCM2 = PCMD**2
+ PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
+ IF(PCMP2.LE.0.D0) THEN
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+ TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
+ & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
+C
+ IF(TMINP.LT.TMAX) THEN
+ IF(IDEB(44).GE.3) THEN
+ WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
+ & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
+ & XM1,XM2,TMIN,TMAX,TMINP
+ ENDIF
+ IFAIL(32) = IFAIL(32)+1
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+ TMINA = MIN(TMIN,TMINP)
+C
+C calculation of slope (mass-dependent parametrization)
+ IF(IDF1+IDF2.GT.0) THEN
+C diffraction dissociation
+ XMP12 = XM1**2+PVIRTD(1)
+ XMP22 = XM2**2+PVIRTD(2)
+ XMX1 = SQRT(XMP12)
+ XMX2 = SQRT(XMP22)
+ CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
+ FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
+ SLOPE = DBLE(IDF1+IDF2)*B0PPP
+ & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
+ & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
+ SLOPE = MAX(SLOPE,1.D0)
+C
+ XMA1 = XMX
+ XMA2 = XMX
+ IF(IDF1.EQ.0) THEN
+ XMA1 = XM1
+ ELSE IF(IDF1.EQ.0) THEN
+ XMA2 = XM2
+ ENDIF
+ XMP12 = XMA1**2+PVIRTD(1)
+ XMP22 = XMA2**2+PVIRTD(2)
+ XMX1 = SQRT(XMP12)
+ XMX2 = SQRT(XMP22)
+ CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
+ SLMIN = DBLE(IDF1+IDF2)*B0PPP
+ & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
+ & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
+ SLMIN = MAX(SLMIN,1.D0)
+ ELSE
+C elastic/quasi-elastic scattering
+ IF(ISWMDL(13).EQ.0) THEN
+C external slope values
+C PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
+ CALL PHO_ABORT
+ ELSE IF(ISWMDL(13).EQ.1) THEN
+C model slopes
+ IF(IVEC1*IVEC2.EQ.0) THEN
+ SLOPE = SLOEL
+ ELSE
+ SLOPE = SLOVM(IVEC1,IVEC2)
+ ENDIF
+ SLMIN = SLOPE
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
+ & ISWMDL(13)
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+C determine max. abs(t) to avoid underflows
+ TMAXP = -25.D0/SLOPE
+ TMAXA = MAX(TMAX,TMAXP)
+C
+ IF(TMINA.LT.TMAXA) THEN
+ IF(IDEB(44).GE.3) THEN
+ WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
+ & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
+ & XM1,XM2,TMINA,TMAXA,SLOPE
+ ENDIF
+ IFAIL(32) = IFAIL(32)+1
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+C
+C sampling from corrected range of T
+ TMINE = EXP(SLMIN*TMINA)
+ TMAXE = EXP(SLMIN*TMAXA)
+ XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
+ TT = LOG(XI)/SLMIN
+ SLWGHT = EXP((SLOPE-SLMIN)*TT)
+C
+C debug output
+ IF(IDEB(44).GE.15) THEN
+ WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
+ & 'PHO_DIFSLP: sampled momentum transfer:',TT,
+ & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
+ & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
+ ENDIF
+ END
+
+*$ CREATE PHO_DIFKIN.FOR
+*COPY PHO_DIFKIN
+CDECK ID>, PHO_DIFKIN
+ SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
+C**********************************************************************
+C
+C calculation of diffractive kinematics
+C
+C input: XMP1 mass of outgoing particle system 1 (GeV)
+C XMP2 mass of outgoing particle system 2 (GeV)
+C TT momentum transfer (GeV**2, negative)
+C
+C output: PMOM1(5) four momentum of outgoing system 1
+C PMOM2(5) four momentum of outgoing system 2
+C IREJ 0 kinematics consistent
+C 1 kinematics inconsistent
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10,
+ & DEPS = 0.001)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PMOM1,PMOM2
+ DIMENSION PMOM1(5),PMOM2(5)
+
+C debug output
+ IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
+ & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
+ & ECMD,PCMD,XMP1,XMP2,TT
+
+C general kinematic constraints
+ IREJ = 1
+ IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
+
+C new squared cms momentum
+ XMP12 = XMP1**2
+ XMP22 = XMP2**2
+ SS = ECMD**2
+ PCM2 = PCMD**2
+ PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
+
+C new longitudinal/transverse momentum
+ E1I = SQRT(PCM2+PMASSD(1)**2)
+ E1F = SQRT(PCMP2+XMP12)
+ E2F = SQRT(PCMP2+XMP22)
+ PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
+ PTRAN = PCMP2-PLONG**2
+
+C check consistency of kinematics
+ IF(PTRAN.LT.0.D0) THEN
+ IF(IDEB(49).GE.1) THEN
+ WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
+ & 'inconsistent kinematics in event call: ',KEVENT
+ WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
+ & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
+ & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ELSE
+ PTRAN = SQRT(PTRAN)
+ ENDIF
+ XI = PI2*DT_RNDM(PTRAN)
+
+C outgoing momenta in cm. system
+ PMOM1(4) = E1F
+ PMOM1(1) = PTRAN*COS(XI)
+ PMOM1(2) = PTRAN*SIN(XI)
+ PMOM1(3) = PLONG
+ PMOM1(5) = XMP1
+
+ PMOM2(4) = E2F
+ PMOM2(1) = -PMOM1(1)
+ PMOM2(2) = -PMOM1(2)
+ PMOM2(3) = -PLONG
+ PMOM2(5) = XMP2
+ IREJ = 0
+
+C debug output / precision check
+ IF(IDEB(49).GE.0) THEN
+C check kinematics
+ XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
+ & -PMOM1(1)**2-PMOM1(2)**2
+ XM1 = SIGN(SQRT(ABS(XM1)),XM1)
+ XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
+ & -PMOM2(1)**2-PMOM2(2)**2
+ XM2 = SIGN(SQRT(ABS(XM2)),XM2)
+ IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
+ WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
+ & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
+ & XMP1,XM1,XMP2,XM2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C output
+ IF(IDEB(49).GT.10) THEN
+ WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
+ & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_VECRES.FOR
+*COPY PHO_VECRES
+CDECK ID>, PHO_VECRES
+ SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
+C**********************************************************************
+C
+C sampling of vector meson resonance in diffractive processes
+C (nothing done for hadrons)
+C
+C input: /POSVDM/ VDMFAC factors
+C
+C output: IVEC 0 incoming hadron
+C 1 rho 0
+C 2 omega
+C 3 phi
+C 4 pi+/pi- background
+C RMASS mass of vector meson (GeV)
+C IDPDG particle ID according to PDG
+C IDBAM particle ID according to CPC
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C particle code translation
+ DIMENSION ITRANS(4)
+C rho0,omega,phi,pi+/pi-
+ DATA ITRANS /113, 223, 333, 92 /
+
+ IDPDO = IDPDG
+C
+C vector meson production
+ IF(IDPDG.EQ.22) THEN
+ XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
+ SUM = 0.D0
+ DO 55 K=1,4
+ SUM = SUM + VMFA(K)
+ IF(XI.LE.SUM) GOTO 65
+ 55 CONTINUE
+ 65 CONTINUE
+C
+ IDPDG = ITRANS(K)
+ IDBAM = ipho_pdg2id(IDPDG)
+ IVEC = K
+C sample mass of vector meson
+ CALL PHO_SAMASS(IDPDG,RMASS)
+
+C hadronic resonance of multi-pomeron coupling
+ ELSE IF(IDPDG.EQ.990) THEN
+ K = 4
+ IDPDG = 91
+ IDBAM = ipho_pdg2id(IDPDG)
+ IVEC = 4
+C sample mass of two-pion system
+ CALL PHO_SAMASS(IDPDG,RMASS)
+
+C hadron remnants in inucleus interactions
+ ELSE IF(IDPDG.EQ.81) THEN
+ IF(IHFLD(1,1).EQ.0) THEN
+ CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
+ CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
+ ELSE
+ CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
+ ENDIF
+ RMAS1 = PHO_PMASS(IDBA1,0)
+ RMAS2 = PHO_PMASS(IDBA2,0)
+ IF((IDBA2.NE.0).AND.
+ & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
+ IDBAM = IDBA2
+ RMASS = RMAS2
+ ELSE
+ IDBAM = IDBA1
+ RMASS = RMAS1
+ ENDIF
+ IDPDG = IPHO_ID2PDG(IDBAM)
+ IVEC = 0
+ ELSE IF(IDPDG.EQ.82) THEN
+ IF(IHFLD(2,1).EQ.0) THEN
+ CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
+ CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
+ ELSE
+ CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
+ ENDIF
+ RMAS1 = PHO_PMASS(IDBA1,0)
+ RMAS2 = PHO_PMASS(IDBA2,0)
+ IF((IDBA2.NE.0).AND.
+ & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
+ IDBAM = IDBA2
+ RMASS = RMAS2
+ ELSE
+ IDBAM = IDBA1
+ RMASS = RMAS1
+ ENDIF
+ IDPDG = IPHO_ID2PDG(IDBAM)
+ IVEC = 0
+ ENDIF
+C debug output
+ IF(IDEB(47).GE.5) THEN
+ WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
+ & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
+ & IDPDO,IDPDG,IDBAM,RMASS
+ ENDIF
+
+ END
+
+*$ CREATE PHO_DIFRES.FOR
+*COPY PHO_DIFRES
+CDECK ID>, PHO_DIFRES
+ SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
+ & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
+C**********************************************************************
+C
+C list of resonance states for low mass resonances
+C
+C input: IDMOTH PDG ID of mother particle
+C IVAL1,2 quarks (photon only)
+C
+C output: IDPDG list of PDG IDs for possible resonances
+C IDBAM list of corresponding CPC IDs
+C RMASS mass
+C RGAMS decay width
+C RMASS additional weight factor
+C LISTL entries in current list
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
+
+ PARAMETER (EPS = 1.D-10,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
+ DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
+ & 12212, 42212, -12212, -42212,
+ & 8*0 /
+ DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
+ & 8*1.D0 /
+
+ DATA init /0/
+
+C initialize table
+ if(init.eq.0) then
+ do i=1,20
+ if(IRPDG(i).ne.0) then
+ IRBAM(i) = ipho_pdg2id(IRPDG(i))
+ endif
+ enddo
+ init = 1
+ endif
+
+C copy table with particles and isospin weights
+ LISTL = 0
+ IF(IDMOTH.EQ.22) THEN
+ I1 = 4
+ I2 = 8
+ ELSE IF(IDMOTH.EQ.2212) THEN
+ I1 = 9
+ I2 = 10
+ ELSE IF(IDMOTH.EQ.-2212) THEN
+ I1 = 11
+ I2 = 12
+ ELSE
+ RETURN
+ ENDIF
+
+ DO 100 I=I1,I2
+ LISTL = LISTL+1
+ IDBAM(LISTL) = IRBAM(I)
+ IDPDG(LISTL) = IRPDG(I)
+ RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
+ RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
+ RWG(LISTL) = RWGHT(I)
+ 100 CONTINUE
+
+C debug output
+ IF(IDEB(85).GE.20) THEN
+ WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
+ & IVAL1,IVAL2
+ DO 200 I=1,LISTL
+ WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
+ 200 CONTINUE
+ ENDIF
+
+ END
+
+*$ CREATE PHO_MASSAD.FOR
+*COPY PHO_MASSAD
+CDECK ID>, PHO_MASSAD
+ SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
+ & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
+C***********************************************************************
+C
+C fine-correction of low mass strings to mass of corresponding
+C resonance or two particle threshold
+C
+C input: IFLMO PDG ID of mother particle
+C IFL1,2 requested parton flavours
+C (not used at the moment)
+C PMASS reference mass (mass of mother particle)
+C XMCON conjecture of mass
+C
+C output: XMOUT output mass (adjusted input mass)
+C moved ot nearest mass possible
+C IDPDG PDG resonance ID
+C IDcpc CPC resonance ID
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+ DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
+
+ XMINP = XMCON
+ IDPDG = 0
+ IDcpc = 0
+ XMOUT = XMINP
+
+C resonance treatment activated?
+ IF(ISWMDL(23).EQ.0) RETURN
+
+ CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
+ IF(LISTL.LT.1) THEN
+ IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
+ & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
+ & IFLMO,IFL1,IFL2
+ GOTO 50
+ ENDIF
+C mass small?
+ PMASSL = (PMASS+0.15D0)**2
+ XMINP2 = XMINP**2
+C determine resonance probability
+ DM2 = 1.1D0
+ RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
+ IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
+C sample new resonance
+ XWGSUM = 0.D0
+ DO 100 I=1,LISTL
+ XWG(I) = RWG(I)/RMA(I)**2
+ XWGSUM = XWGSUM+XWG(I)
+ 100 CONTINUE
+
+ ITER = 0
+ 150 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.5) THEN
+ IDcpc = 0
+ IDPDG = 0
+ XMOUT = XMINP
+ GOTO 50
+ ENDIF
+
+ I = 0
+ XI = XWGSUM*DT_RNDM(XMOUT)
+ 200 CONTINUE
+ I = I+1
+ XWGSUM = XWGSUM-XWG(I)
+ IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
+ IDPDG = IRPDG(I)
+ IDcpc = IRBAM(I)
+ GARES = RGA(I)
+ XMRES = RMA(I)
+ XMRES2 = XMRES**2
+C sample new mass (from Breit-Wigner cross section)
+ ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
+ AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
+ XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
+ XMOUT = XMRES*GARES*TAN(XI)+XMRES2
+ XMOUT = SQRT(XMOUT)
+
+C check mass for decay
+ AMDCY = 2.D0*XMRES
+ ID = abs(IDcpc)
+ DO 250 IK=idec_list(2,ID),idec_list(3,ID)
+ AMSUM = 0.D0
+ DO 275 I=1,3
+ IF(isec_list(I,IK).NE.0)
+ & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
+ 275 CONTINUE
+ AMDCY = MIN(AMDCY,AMSUM)
+ 250 CONTINUE
+ IF(AMDCY.GE.XMOUT) GOTO 150
+
+C debug output
+ IF(IDEB(7).GE.10)
+ & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
+ & 'PHO_MASSAD: ',
+ & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
+ & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
+ RETURN
+ ENDIF
+
+ 50 CONTINUE
+C debug output
+ IF(IDEB(7).GE.15)
+ & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
+ & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
+ & IFLMO,IFL1,IFL2,XMCON,XMOUT
+
+ END
+
+*$ CREATE PHO_PDF.FOR
+*COPY PHO_PDF
+CDECK ID>, PHO_PDF
+ SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
+C***************************************************************
+C
+C call different PDF sets for different particle types
+C
+C input: NPAR 1 IGRP(1),ISET(1)
+C 2 IGRP(2),ISET(2)
+C X momentum fraction
+C SCALE2 squared scale (GeV**2)
+C P2VIR particle virtuality (positive, GeV**2)
+C
+C output PD(-6:6) field containing the x*PDF fractions
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION PD(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+
+ REAL XR,P2R,Q2R,F2GM,XPDFGM
+ DIMENSION XPDFGM(-6:6)
+
+C check of kinematic boundaries
+ XI = X
+ IF(X.GT.1.D0) THEN
+ IF(IDEB(37).GE.0) THEN
+ WRITE(LO,'(/,1X,A,E15.8/)')
+ & 'PHO_PDF: x>1 (corrected to x=1)',X
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ XI = 0.99999999999D0
+ ELSE IF(X.LE.0.D0) THEN
+ IF(IDEB(37).GE.0) THEN
+ WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ XI = 0.0001D0
+ ENDIF
+
+ DO 100 I=-6,6
+ PD(I) = 0.D0
+ 100 CONTINUE
+ IRET = 1
+
+ IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
+
+C internal PDFs
+
+ IF(IEXT(NPAR).EQ.0) THEN
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.3) THEN
+ CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
+ UV = UDV-DV
+ UDB = 2.D0*UDB
+ DEL = 0.D0
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
+ UV = UDV-DV
+ UDB = 2.D0*UDB
+ DEL = 0.D0
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.5) THEN
+ CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
+C heavy quarks from GRV92-HO
+ AMU2 = 0.3
+ ALAM2 = 0.248 * 0.248
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.6) THEN
+ CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.7) THEN
+ CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
+C heavy quarks from GRV92-HO
+ AMU2 = 0.3
+ ALAM2 = 0.248 * 0.248
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.8) THEN
+ CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
+ DEL = DS-US
+ UDB = DS+US
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.9) THEN
+* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
+ DEL = DS-US
+ UDB = DS+US
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ENDIF
+ PD(-5) = BB
+ PD(-4) = CB
+ PD(-3) = SB
+ PD(-2) = 0.5D0*(UDB-DEL)
+ PD(-1) = 0.5D0*(UDB+DEL)
+ PD(0) = GL
+ PD(1) = DV+PD(-1)
+ PD(2) = UV+PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pion PDFs (default for pi+)
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
+ IRET = 0
+ ENDIF
+ PD(-5) = BB
+ PD(-4) = CB
+ PD(-3) = QB
+ PD(-2) = QB
+ PD(-1) = QB+VA
+ PD(0) = GL
+ PD(1) = QB
+ PD(2) = VA+QB
+ PD(3) = QB
+ PD(4) = CB
+ PD(5) = BB
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ENDIF
+C reweight with Drees-Godbole factor
+ WGX = 1.D0
+ IF(P2VIR.GT.0.001D0) THEN
+ WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
+ & /LOG(SCALE2/PARMDL(144))
+ WGX = MAX(WGX,0.D0)
+ ENDIF
+ PD(-5) = BB*WGX/137.D0
+ PD(-4) = CB*WGX/137.D0
+ PD(-3) = SB*WGX/137.D0
+ PD(-2) = UB*WGX/137.D0
+ PD(-1) = DB*WGX/137.D0
+ PD(0) = GL*WGX*WGX/137.D0
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ELSE IF(IGRP(NPAR).EQ.8) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_PHGAL (XI,SCALE2,PD)
+ IRET = 0
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.20) THEN
+C Pomeron PDFs
+ MODE = IGRP(NPAR)
+ IF(MODE.EQ.1) THEN
+ PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.2) THEN
+ PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.3) THEN
+ PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.4) THEN
+ CALL PHO_CKMTPD(990,XI,SCALE2,PD)
+ DO 105 I=-4,4
+ PD(I) = PD(I)*PARMDL(78)
+ 105 CONTINUE
+ IRET = 0
+ ENDIF
+ ENDIF
+
+C external PDFs
+
+ ELSE IF(IEXT(NPAR).EQ.2) THEN
+C PDFLIB call: new PDF numbering
+ IF(NPAR.NE.NPAOLD) THEN
+ PARAM(1) = 'NPTYPE'
+ PARAM(2) = 'NGROUP'
+ PARAM(3) = 'NSET'
+ PARAM(4) = ' '
+ VALUE(1) = ITYPE(NPAR)
+ VALUE(2) = ABS(IGRP(NPAR))
+ VALUE(3) = ISET(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ ENDIF
+ IF(ITYPE(NPAR).EQ.3) THEN
+ IP2 = 0
+ CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
+ & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
+ ELSE
+ SCALE = SQRT(SCALE2)
+ CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
+ & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
+ ENDIF
+ DO 115 I=3,6
+ PD(I) = PD(-I)
+ 115 CONTINUE
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton valence quarks
+ PD(1) = PD(1)+PD(-1)
+ PD(2) = PD(2)+PD(-2)
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pi+ valences
+ DVAL = PD(1)
+ PD(1) = PD(-1)
+ PD(-1) = DVAL+PD(1)
+ PD(2) = PD(2)+PD(-2)
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon conventions
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ IRET = 0
+
+ ELSE IF(IEXT(NPAR).EQ.3) THEN
+C PHOLIB call: version 2.0
+ CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
+ IF(IRET.LT.0) THEN
+ WRITE(LO,'(/1X,A,I2)')
+ & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
+ CALL PHO_ABORT
+ ENDIF
+ IRET = 0
+
+C photon PDFs depending on photon virtuality
+
+ ELSE IF(IEXT(NPAR).EQ.4) THEN
+ IF(IGRP(NPAR).EQ.1) THEN
+C Schuler/Sjostrand PDF (interface to single precision)
+ XR = XI
+ Q2R = SCALE2
+ P2R = P2VIR
+ IP2 = 0
+ CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
+ DO 120 I=-6,6
+ PD(I) = DBLE(XPDFGM(I))
+ 120 CONTINUE
+ IRET = 0
+ ELSE IF(IGRP(NPAR).EQ.5) THEN
+C Gluck/Reya/Stratmann
+ IF(ISET(NPAR).EQ.4) THEN
+ CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
+ CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
+ IRET = 0
+ PD(-5) = 0.D0
+ PD(-4) = CB
+ PD(-3) = SB/137.D0
+ PD(-2) = UB/137.D0
+ PD(-1) = DB/137.D0
+ PD(0) = GL/137.D0
+ PD(1) = PD(-1)
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ENDIF
+ ENDIF
+ ENDIF
+
+C check for errors
+
+ IF(IRET.NE.0) THEN
+ WRITE(LO,'(/1X,A,/10X,5I6)')
+ & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
+ & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
+ CALL PHO_ABORT
+ ENDIF
+C error in NPAR
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
+ CALL PHO_ABORT
+ ENDIF
+ NPAOLD = NPAR
+
+C valence quark treatment
+
+ IF(ITYPE(NPAR).EQ.2) THEN
+C meson conventions
+ IF(IPARID(NPAR).EQ.111) THEN
+C pi0 valence quarks
+ PD(-1) = (PD(1)+PD(-1))/2.D0
+ PD(1) = PD(-1)
+ PD(-2) = (PD(2)+PD(-2))/2.D0
+ PD(2) = PD(-2)
+ ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
+C K+/-
+ VALS = PD(-1)-PD(1)
+ PD(-1) = PD(1)
+ PD(-3) = PD(-3)+VALS
+ ELSE IF( (IPARID(NPAR).EQ.311)
+ & .OR.(IPARID(NPAR).EQ.310)
+ & .OR.(IPARID(NPAR).EQ.130)) THEN
+C neutral kaons
+ VALS = PD(-1)-PD(1)
+ VALU = PD(2)-PD(-2)
+ PD(-1) = PD(1)
+ PD(2) = PD(-2)
+ PD(2) = PD(2)+VALU/2.D0
+ PD(-2) = PD(-2)+VALU/2.D0
+ PD(3) = PD(3)+VALS/2.D0
+ PD(-3) = PD(-3)+VALS/2.D0
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.1) THEN
+C nucleon conventions
+ IF(ABS(IPARID(NPAR)).EQ.2112) THEN
+C neutron valence quarks
+ DUM = PD(1)
+ PD(1) = PD(2)
+ PD(2) = DUM
+ ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
+C (anti-)sigma+
+ VALS = PD(1)-PD(-1)
+ PD(1) = PD(-1)
+ PD(3) = PD(3)+VALS
+ ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
+C (anti-)sigma-
+ VALS = PD(1)-PD(-1)
+ VALD = PD(2)-PD(-2)
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(1) = PD(1)+VALD
+ PD(3) = PD(3)+VALS
+ ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
+ & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
+C (anti-)sigma0 and (anti-)lambda
+ VALS = PD(1)-PD(-1)
+ VALD = (PD(2)-PD(-2))/2.D0
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(1) = PD(1)+VALD
+ PD(2) = PD(2)+VALD
+ PD(3) = PD(3)+VALS
+ ENDIF
+ ENDIF
+
+C antiparticle
+ IF(IPARID(NPAR).LT.0) THEN
+ DO 190 I=1,4
+ DUM=PD(I)
+ PD(I)=PD(-I)
+ PD(-I)=DUM
+ 190 CONTINUE
+ ENDIF
+
+C optionally remove valence quarks
+ IF(IPAVA(NPAR).EQ.0) THEN
+ DO 200 I=1,4
+ PD(I) = MIN(PD(-I),PD(I))
+ PD(-I) = PD(I)
+ 200 CONTINUE
+ ENDIF
+
+C debug information
+ IF(IDEB(37).GE.30) WRITE(LO,
+ & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
+ & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
+ & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
+ & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
+
+ END
+
+*$ CREATE PHO_QPMPDF.FOR
+*COPY PHO_QPMPDF
+CDECK ID>, PHO_QPMPDF
+ SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
+C***************************************************************
+C
+C contribution to photon PDF from box graph
+C (Bethe-Heitler process)
+C
+C input: IQ quark flavour
+C SCALE2 scale (GeV**2, positive)
+C PTREF reference scale (GeV, positive)
+C X parton momentum fraction
+C PVIRT photon virtuality (GeV**2, positive)
+C FXP x*f(x,Q**2), x times parton density
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION QM(6)
+ DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
+
+ FXP = 0.D0
+ I = ABS(IQ)
+C
+* QM2 = MAX(QM(I),PTREF)**2
+* QM2 = MAX(QM2,PVIRT)
+* BBE = (1.D0-X)*SCALE2
+* IF(BBE.LE.0.D0) THEN
+* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
+* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
+* & PVIRT,QM(I)
+* ENDIF
+* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
+* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
+C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
+ QM2 = MAX(QM(I),PTREF)**2
+ W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
+ IF(W2.GT.4.D0*QM2) THEN
+ BE = SQRT(1.D0-4.D0*QM2/W2)
+ BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
+ BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
+* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
+ FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
+ & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
+ & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
+ & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
+ & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
+ ELSE
+ IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
+ & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
+ & PVIRT,QM(I)
+ ENDIF
+C debug output
+ IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
+ & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
+ END
+
+*$ CREATE PHO_SETPDF.FOR
+*COPY PHO_SETPDF
+CDECK ID>, PHO_SETPDF
+ SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
+C***************************************************************
+C
+C assigns PDF numbers to particles
+C
+C input: IDPDG PDG number of particle
+C ITYP particle type
+C IPAR PDF paramertization
+C ISET number of set
+C IEXT library number for PDF calculation
+C IPAVAL (only output)
+C 1 PDF with valence quarks
+C 0 PDF without valence quarks
+C MODE -1 add entry to table
+C 1 read from table
+C 2 output of table
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+ DIMENSION IPDFS(5,50)
+ DATA IENTRY / 0 /
+
+ IF(MODE.EQ.1) THEN
+ I = 1
+ IF(IDPDG.EQ.81) THEN
+ IDCMP = IDEQP(1)
+ IPAVAL = IHFLS(1)
+ ELSE IF(IDPDG.EQ.82) THEN
+ IDCMP = IDEQP(2)
+ IPAVAL = IHFLS(2)
+ ELSE
+ IDCMP = IDPDG
+ IPAVAL = 1
+ ENDIF
+200 CONTINUE
+ IF(IDCMP.EQ.IPDFS(1,I)) THEN
+ ITYP = IPDFS(2,I)
+ IPAR = IPDFS(3,I)
+ ISET = IPDFS(4,I)
+ IEXT = IPDFS(5,I)
+ IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
+ & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
+ RETURN
+ ENDIF
+ I = I+1
+ IF(I.GT.IENTRY) THEN
+ WRITE(LO,'(/1X,A,I7)')
+ & 'PHO_SETPDF: no PDF assigned to ',IDCMP
+ CALL PHO_ABORT
+ ENDIF
+ GOTO 200
+ ELSE IF(MODE.EQ.-1) THEN
+ DO 50 I=1,IENTRY
+ IF(IDPDG.EQ.IPDFS(1,I)) THEN
+ WRITE(LO,'(/1X,A,5I6)')
+ & 'PHO_SETPDF: overwrite old particle PDF',
+ & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ GOTO 100
+ ENDIF
+ 50 CONTINUE
+ I = IENTRY+1
+ IF(I.GT.50) THEN
+ WRITE(LO,'(/1X,A,/1x,6I6)')
+ & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
+ & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ STOP
+ ENDIF
+ IENTRY = I
+ 100 CONTINUE
+ IPDFS(1,I) = IDPDG
+ IF(IDPDG.EQ.990) THEN
+ ITYP1 = 20
+ ELSE IF(IDPDG.EQ.22) THEN
+ ITYP1 = 3
+ ELSE IF(ABS(IDPDG).LT.1000) THEN
+ ITYP1 = 2
+ ELSE
+ ITYP1 = 1
+ ENDIF
+ IPDFS(2,I) = ITYP1
+ IPDFS(3,I) = IPAR
+ IPDFS(4,I) = ISET
+ IPDFS(5,I) = IEXT
+ ELSE IF(MODE.EQ.-2) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
+ DO 150 I=1,IENTRY
+ WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
+ & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ 150 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
+ ENDIF
+ END
+
+*$ CREATE PHO_GETPDF.FOR
+*COPY PHO_GETPDF
+CDECK ID>, PHO_GETPDF
+ SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
+C***************************************************************
+C
+C get PDF information
+C
+C input: NPAR 1 first PDF in /POPPDF/
+C 2 second PDF in /POPPDF/
+C
+C output: PDFNA name of PDf parametrization
+C ALA QCD LAMBDA (4 flavours, in GeV)
+C Q2MI minimal Q2
+C Q2MA maximal Q2
+C XMI minimal X
+C XMA maximal X
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CHARACTER*8 PDFNA
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+C PHOLIB 4.15 common
+ COMMON /W50512/ QCDL4,QCDL5
+ COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
+
+C PHOPDF version 2.0 common
+ PARAMETER (MAXS=6,MAXP=10)
+ CHARACTER*4 CHPAR
+ COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
+ & NSET(MAXP,2),NFL(MAXP)
+ COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
+
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+
+ IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
+ WRITE(LO,'(/1X,A,I6)')
+ & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
+ CALL PHO_ABORT
+ ENDIF
+ ALA = 0.D0
+
+ IF(IEXT(NPAR).EQ.0) THEN
+
+C internal parametrizations
+
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.3) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV92 HO'
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV92 LO'
+ ELSE IF(ISET(NPAR).EQ.5) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 HO'
+ ELSE IF(ISET(NPAR).EQ.6) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 LO'
+ ELSE IF(ISET(NPAR).EQ.7) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 DI'
+ ELSE IF(ISET(NPAR).EQ.8) THEN
+ ALA = 0.175D0
+ Q2MI = 0.8D0
+ PDFNA = 'GRV98 LO'
+ ELSE IF(ISET(NPAR).EQ.9) THEN
+ ALA = 0.175D0
+ Q2MI = 0.8D0
+ PDFNA = 'GRV98 SC'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pion PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-P HO'
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV-P LO'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-G LH'
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-G HO'
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV-G LO'
+ ENDIF
+ ELSE IF(IGRP(NPAR).EQ.8) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 4.D0
+ PDFNA = 'AGL-G LO'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.20) THEN
+C pomeron PDFs
+ IF(IGRP(NPAR).EQ.4) THEN
+ CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
+ ELSE
+ ALA = 0.3D0
+ Q2MI = 2.D0
+ PDFNA = 'POM-PDF1'
+ ENDIF
+ ENDIF
+
+C external parametrizations
+
+ ELSE IF(IEXT(NPAR).EQ.1) THEN
+C PDFLIB call: old numbering
+ PARAM(1) = 'MODE'
+ PARAM(2) = ' '
+ VALUE(1) = IGRP(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ Q2MI = Q2MIN
+ Q2MA = Q2MAX
+ XMI = XMIN
+ XMA = XMAX
+ ALA = QCDL4
+ PDFNA = 'PDFLIB1'
+ ELSE IF(IEXT(NPAR).EQ.2) THEN
+C PDFLIB call: new numbering
+ PARAM(1) = 'NPTYPE'
+ PARAM(2) = 'NGROUP'
+ PARAM(3) = 'NSET'
+ PARAM(4) = ' '
+ VALUE(1) = ITYPE(NPAR)
+ VALUE(2) = IGRP(NPAR)
+ VALUE(3) = ISET(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ Q2MI = Q2MIN
+ Q2MA = Q2MAX
+ XMI = XMIN
+ XMA = XMAX
+ ALA = QCDL4
+ PDFNA = 'PDFLIB2'
+ ELSE IF(IEXT(NPAR).EQ.3) THEN
+C PHOLIB interface
+ ALA = ALM(IGRP(NPAR),ISET(NPAR))
+ Q2MI = 2.D0
+ PDFNA = CHPAR(IGRP(NPAR))
+
+C some special internal parametrizations
+
+ ELSE IF(IEXT(NPAR).EQ.4) THEN
+C photon PDFs depending on virtualities
+ IF(IGRP(NPAR).EQ.1) THEN
+C Schuler/Sjostrand parametrization
+ ALA = 0.2D0
+ IF(ISET(NPAR).EQ.1) THEN
+ Q2MI = 0.2D0
+ PDFNA = 'SaS-1D '
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ Q2MI = 0.2D0
+ PDFNA = 'SaS-1M '
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ Q2MI = 2.D0
+ PDFNA = 'SaS-2D '
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ Q2MI = 2.D0
+ PDFNA = 'SaS-2M '
+ ENDIF
+ ELSE IF(IGRP(NPAR).EQ.5) THEN
+C Gluck/Reya/Stratmann parametrization
+ IF(ISET(NPAR).EQ.4) THEN
+ ALA = 0.2D0
+ Q2MI = 0.6D0
+ PDFNA = 'GRS-G LO'
+ ENDIF
+ ENDIF
+ ELSE IF(IEXT(NPAR).EQ.5) THEN
+C Schuler/Sjostrand anomalous only
+ ALA = 0.2D0
+ Q2MI = 0.2D0
+ PDFNA = 'SaS anom'
+ ENDIF
+ IF(ALA.LT.0.01D0) THEN
+ WRITE(LO,'(/1X,2A,/10X,5I6)')
+ & 'PHO_GETPDF:ERROR: ',
+ & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
+ & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+*$ CREATE PHO_ACTPDF.FOR
+*COPY PHO_ACTPDF
+CDECK ID>, PHO_ACTPDF
+ SUBROUTINE PHO_ACTPDF(IDPDG,K)
+C***************************************************************
+C
+C activate PDF for QCD calculations
+C
+C input: IDPDG PDG particle number
+C K 1 first PDF in /POPPDF/
+C 2 second PDF in /POPPDF/
+C -2 write current settings
+C
+C output: /POPPDF/
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ IF(K.GT.0) THEN
+
+C read PDF from table
+ CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
+ & IPAVA(K),1)
+ IPARID(K) = IDPDG
+C get PDF parameters
+ CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
+C initialize alpha_s calculation
+ alam2 = PDFLAM(K)*PDFLAM(K)
+ DUMMY = PHO_ALPHAS(alam2,-K)
+
+ IF(IDEB(2).GE.20) THEN
+ WRITE(LO,'(1X,A)')
+ & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
+ WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
+ & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
+ & IEXT(K),IPARID(K)
+ ENDIF
+ NPAOLD = K
+
+ ELSE IF(K.EQ.-2) THEN
+
+C write table of current PDFs
+ WRITE(LO,'(1X,A)')
+ & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
+ WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
+ & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
+ & IPARID(1)
+ WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
+ & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
+ & IPARID(2)
+
+ ELSE
+
+ WRITE(LO,'(/1X,A,2I4)')
+ & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
+ CALL PHO_ABORT
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PDFTST.FOR
+*COPY PHO_PDFTST
+CDECK ID>, PHO_PDFTST
+ SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
+C*********************************************************************
+C
+C structure function test utility
+C
+C input: IDPDG PDG ID of particle
+C SCALE2 squared scale (GeV**2)
+C P2MASS particle virtuality (pos, GeV**2)
+C
+C output: tables of PDF, sum rule checking, table of F2
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
+ CHARACTER*8 PDFNA
+
+ CALL PHO_ACTPDF(IDPDG,1)
+ CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
+
+ WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
+ WRITE(LO,'(A)') ' ======================================='
+
+ WRITE(LO,'(/,A,3I10)')
+ & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
+ WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
+ WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
+ WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
+ WRITE(LO,'(/1X,A)') 'x times parton densities'
+ WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
+ WRITE(LO,'(1X,A)')
+ & ' ============================================================'
+
+C logarithmic loop over x values
+C upper bound
+ XUPPER=0.9999D0
+C lower bound
+ XLOWER=1.D-4
+C number of steps
+ NSTEP=50
+
+ XFIRST=LOG(XLOWER)
+ XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
+ DO 100 I=1,NSTEP
+ X=EXP(XFIRST)
+ XCONTR=X
+ CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
+ IF(X.NE.XCONTR) THEN
+ WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
+ ENDIF
+ WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
+ XFIRST=XFIRST+XDELTA
+ 100 CONTINUE
+
+ IF(IDPDG.EQ.22) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'comparison PDF to contribution due to box diagram'
+ WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
+ WRITE(LO,'(1X,A)')
+ & ' ============================================================'
+ XFIRST=LOG(XLOWER)
+ XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
+ DO 110 I=1,NSTEP
+ X=EXP(XFIRST)
+ CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
+ DO 120 K=1,4
+ CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
+ 120 CONTINUE
+ WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
+ XFIRST=XFIRST+XDELTA
+ 110 CONTINUE
+ ENDIF
+
+C check momentum sum rule
+
+ WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
+ DO 199 I=-6,6
+ PDSUM(I) = 0.D0
+ PDAVE(I) = 0.D0
+ 199 CONTINUE
+ ITER=5000
+ DO 200 I=1,ITER
+ XX=DBLE(I)/DBLE(ITER)
+ IF(XX.EQ.1.D0) XX = 0.999999D0
+ CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
+ DO 202 K=-6,6
+ PDSUM(K) = PDSUM(K)+PD(K)/XX
+ PDAVE(K) = PDAVE(K)+PD(K)
+ 202 CONTINUE
+ 200 CONTINUE
+ WRITE(LO,'(1X,A)')
+ & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
+ XSUM = 0.D0
+ DO 204 I=-6,6
+ PDSUM(I) = PDSUM(I)/DBLE(ITER)
+ PDAVE(I) = PDAVE(I)/DBLE(ITER)
+ XSUM = XSUM+PDAVE(I)
+ WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
+ 204 CONTINUE
+ WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
+ DO 205 I=1,6
+ WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
+ 205 CONTINUE
+ WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
+ WRITE(LO,'(A/)') ' ============================================='
+
+C table of F2
+
+ WRITE(LO,'(/1X,A,E12.4,/1X,A)')
+ & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
+ & '-----------------------------------------------------'
+ ITER=100
+ DO 300 I=1,ITER
+ XX=DBLE(I)/DBLE(ITER)
+ IF(XX.EQ.1.D0) XX = 0.9999D0
+ CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
+ F2 = 0.D0
+ DO 302 K=-6,6
+ IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
+ 302 CONTINUE
+ WRITE(LO,'(5X,1P,2E14.5)') XX,F2
+ 300 CONTINUE
+ WRITE(LO,'(A/)') ' ============================================='
+ END
+
+*$ CREATE PHO_REGPAR.FOR
+*COPY PHO_REGPAR
+CDECK ID>, PHO_REGPAR
+ SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
+ & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
+C**********************************************************************
+C
+C registration of particle in /POEVT1/ and /POEVT2/
+C
+C input: ISTH status code of particle
+C -2 initial parton hard scattering
+C -1 parton
+C 0 string
+C 1 visible particle (no color)
+C 2 decayed particle
+C IDPDG PDG particle ID code
+C IDBAM CPC particle ID code
+C JM1,JM2 first and second mother index
+C P1..P4 four momentum
+C IPHIS1 extended history information
+C IPHIS1<100: JM1 from particle 1
+C IPHIS1>100: JM1 from particle 2
+C 1 valence quark
+C 2 valence diquark
+C 3 sea quark
+C 4 sea diquark
+C (neg. for antipartons)
+C IPHIS2 extended history information
+C positive: JM2 from particle 1
+C negative: JM2 from particle 2
+C (see IPHIS1)
+C IC1,IC2 color labels for partons
+C IMODE 1 register given parton
+C 0 reset /POEVT1/ and /POEVT2/
+C 2 return data of entry IPOS
+C
+C IPOS position of particle in /POEVT1/
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ IF(IMODE.EQ.1) THEN
+ IF(IDEB(76).GE.26) THEN
+ WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
+ & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
+ & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
+ WRITE(LO,'(1X,A,/2X,6I6)')
+ & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
+ & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
+ ENDIF
+ IF(NHEP.EQ.NMXHEP) THEN
+ WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
+ & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
+ CALL PHO_ABORT
+ ENDIF
+ NHEP = NHEP+1
+ IDBAMI = IDBAM
+ IDPDGI = IDPDG
+ IF(ABS(ISTH).LE.2) THEN
+ IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
+ IDPDGI = ipho_id2pdg(IDBAM)
+ ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
+ IDBAMI = ipho_pdg2id(IDPDG)
+ ENDIF
+ ENDIF
+C standard data
+ ISTHEP(NHEP) = ISTH
+ IDHEP(NHEP) = IDPDGI
+ JMOHEP(1,NHEP) = JM1
+ JMOHEP(2,NHEP) = JM2
+C update of mother-daugther relations
+ IF(ABS(ISTH).LE.1) THEN
+ IF(JM1.GT.0) THEN
+ IF(JDAHEP(1,JM1).EQ.0) THEN
+ JDAHEP(1,JM1) = NHEP
+ ISTHEP(JM1) = 2
+ ENDIF
+ JDAHEP(2,JM1) = NHEP
+ ENDIF
+ IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
+ IF(JDAHEP(1,JM2).EQ.0) THEN
+ JDAHEP(1,JM2) = NHEP
+ ISTHEP(JM2) = 2
+ ENDIF
+ JDAHEP(2,JM2) = NHEP
+ ELSE IF(JM2.LT.0) THEN
+ DO 100 II=JM1+1,-JM2
+ IF(JDAHEP(1,II).EQ.0) THEN
+ JDAHEP(1,II) = NHEP
+ ISTHEP(II) = 2
+ ENDIF
+ JDAHEP(2,II) = NHEP
+100 CONTINUE
+ ENDIF
+ ENDIF
+ PHEP(1,NHEP) = P1
+ PHEP(2,NHEP) = P2
+ PHEP(3,NHEP) = P3
+ PHEP(4,NHEP) = P4
+ IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
+ TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
+ PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
+ ELSE
+ PHEP(5,NHEP) = 0.D0
+ ENDIF
+ JDAHEP(1,NHEP) = 0
+ JDAHEP(2,NHEP) = 0
+C extended information
+ IMPART(NHEP) = IDBAMI
+C extended history information
+ IPHIST(1,NHEP) = IPHIS1
+ IPHIST(2,NHEP) = IPHIS2
+C charge/baryon number or color labels
+ IF(ISTH.EQ.1) THEN
+ ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
+ ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
+ ELSE
+ ICOLOR(1,NHEP) = IC1
+ ICOLOR(2,NHEP) = IC2
+ ENDIF
+
+ IPOS = NHEP
+ IF(IDEB(76).GE.26) THEN
+ WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
+ & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
+ & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
+ & PHEP(5,NHEP),IPOS
+ ENDIF
+
+ ELSE IF(IMODE.EQ.0) THEN
+ NHEP = 0
+ ELSE IF(IMODE.EQ.2) THEN
+ IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
+ WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
+ & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
+ RETURN
+ ENDIF
+ ISTH = ISTHEP(IPOS)
+ IDPDG = IDHEP(IPOS)
+ IDBAM = IMPART(IPOS)
+ JM1 = JMOHEP(1,IPOS)
+ JM2 = JMOHEP(2,IPOS)
+ P1 = PHEP(1,IPOS)
+ P2 = PHEP(2,IPOS)
+ P3 = PHEP(3,IPOS)
+ P4 = PHEP(4,IPOS)
+ IPHIS1= IPHIST(1,IPOS)
+ IPHIS2= IPHIST(2,IPOS)
+ IC1 = ICOLOR(1,IPOS)
+ IC2 = ICOLOR(2,IPOS)
+ ELSE
+ WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
+ ENDIF
+ END
+
+*$ CREATE IPHO_CNV1.FOR
+*COPY IPHO_CNV1
+CDECK ID>, IPHO_CNV1
+ INTEGER FUNCTION IPHO_CNV1(IPART)
+C*********************************************************************
+C
+C conversion of quark numbering scheme to PARTICLE DATA GROUP
+C convention
+C
+C input: old internal particle code of hard scattering
+C 0 gluon
+C 1 d
+C 2 u
+C 3 s
+C 4 c
+C valence quarks changed to standard numbering
+C
+C output: standard particle codes
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ II = ABS(IPART)
+C change gluon number
+ IF(II.EQ.0) THEN
+ IPHO_CNV1 = 21
+C change valence quark
+ ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
+ IPHO_CNV1 = SIGN(II-6,IPART)
+ ELSE
+ IPHO_CNV1 = IPART
+ ENDIF
+ END
+
+*$ CREATE PHO_HACODE.FOR
+*COPY PHO_HACODE
+CDECK ID>, PHO_HACODE
+ SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
+C*********************************************************************
+C
+C determination of hadron index from quarks
+C
+C input: ID1,ID2 parton code according to PDG conventions
+C
+C output: IDcpc1,2 CPC particle codes
+C
+C*********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID1,ID2,IDcpc1,IDcpc2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk,i1,i2
+
+ IDcpc1 = 0
+ IDcpc2 = 0
+
+ if(ID1*ID2.lt.0) then
+C meson
+ if(ID1.gt.0) then
+ ii = ID1
+ jj = -ID2
+ else
+ ii = ID2
+ jj = -ID1
+ endif
+ IDcpc1 = ID_psm_list(ii,jj)
+ IDcpc2 = ID_vem_list(ii,jj)
+
+ else
+C baryon
+ i1 = abs(ID1)
+ i2 = abs(ID2)
+ if(i1.gt.6) then
+ ii = i1/1000
+ jj = (i1-ii*1000)/100
+ kk = i2
+ else
+ ii = i1
+ jj = i2/1000
+ kk = (i2-jj*1000)/100
+ endif
+ IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
+ IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
+
+ endif
+
+ END
+
+*$ CREATE PHO_ID2STR.FOR
+*COPY PHO_ID2STR
+CDECK ID>, PHO_ID2STR
+ SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
+C*********************************************************************
+C
+C conversion of quark numbering scheme
+C
+C input: standard particle codes:
+C ID1
+C ID2
+C
+C output: NOBAM CPC string code
+C quark codes (PDG convention):
+C IBAM1
+C IBAM2
+C IBAM3
+C IBAM4
+C
+C NOBAM = -1 invalid flavour combinations
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ IDA1 = ABS(ID1)
+ IDA2 = ABS(ID2)
+
+C quark-antiquark string
+ IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
+ IF((ID1*ID2).GE.0) GOTO 100
+ IBAM1 = ID1
+ IBAM2 = ID2
+ IBAM3 = 0
+ IBAM4 = 0
+ NOBAM = 3
+C quark-diquark string
+ ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
+ IF((ID1*ID2).LE.0) GOTO 100
+ IBAM1 = ID1
+ IBAM2 = ID2/1000
+ IBAM3 = (ID2-IBAM2*1000)/100
+ IBAM4 = 0
+ NOBAM = 4
+C diquark-quark string
+ ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
+ IF((ID1*ID2).LE.0) GOTO 100
+ IBAM1 = ID1/1000
+ IBAM2 = (ID1-IBAM1*1000)/100
+ IBAM3 = ID2
+ IBAM4 = 0
+ NOBAM = 6
+C gluon-gluon string
+ ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
+ IBAM1 = 21
+ IBAM2 = 21
+ IBAM3 = 0
+ IBAM4 = 0
+ NOBAM = 7
+C diquark-antidiquark string
+ ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
+ IF((ID1*ID2).GE.0) GOTO 100
+ IBAM1 = ID1/1000
+ IBAM2 = (ID1-IBAM1*1000)/100
+ IBAM3 = ID2/1000
+ IBAM4 = (ID2-IBAM3*1000)/100
+ NOBAM = 5
+ ENDIF
+ RETURN
+
+C invalid combination
+ 100 CONTINUE
+ WRITE(LO,'(//1X,A,2I10)')
+ & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
+ CALL PHO_ABORT
+
+ END
+
+*$ CREATE PHO_MKSLTR.FOR
+*COPY PHO_MKSLTR
+CDECK ID>, PHO_MKSLTR
+ SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
+C********************************************************************
+C
+C calculate successive Lorentz boots for arbitrary Lorentz trans.
+C
+C input: P1 initial 4 vector
+C GAM(3),GAMB(3) Lorentz boost parameters
+C
+C output: P2 final 4 vector
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
+
+ P2(4) = P1(4)
+ DO 150 I=1,3
+ P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
+ P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
+ 150 CONTINUE
+ END
+
+*$ CREATE PHO_GETLTR.FOR
+*COPY PHO_GETLTR
+CDECK ID>, PHO_GETLTR
+ SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
+C********************************************************************
+C
+C calculate Lorentz boots for arbitrary Lorentz transformation
+C
+C input: P1 initial 4 vector
+C P2 final 4 vector
+C
+C output: GAM(3),GAMB(3)
+C DELE energy deviation
+C IREJ 0 success
+C 1 failure
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DREL = 0.001D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
+
+ IREJ = 1
+ DO 50 K=1,4
+ PA(K) = P1(K)
+ PP(K) = P1(K)
+ 50 CONTINUE
+ PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
+ DO 100 I=1,3
+ PP(I) = P2(I)
+ PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
+ IF(PP(4).LE.0.D0) RETURN
+ PP(4) = SQRT(PP(4))
+ GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
+ & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
+ GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
+ GAMB(I) = GAMB(I)*GAM(I)
+ DO 150 K=1,4
+ PA(K) = PP(K)
+ 150 CONTINUE
+ 100 CONTINUE
+ DELE = P2(4)-PP(4)
+ IREJ = 0
+C consistency check
+* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
+* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
+* WRITE(LO,'(/1X,A,2E12.5)')
+* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
+* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
+* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
+* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
+* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
+* ENDIF
+ END
+
+*$ CREATE PHO_ALTRA.FOR
+*COPY PHO_ALTRA
+CDECK ID>, PHO_ALTRA
+ SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
+C*********************************************************************
+C
+C arbitrary Lorentz transformation
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ EP=PCX*BGX+PCY*BGY+PCZ*BGZ
+ PE=EP/(GA+1.D0)+EC
+ PX=PCX+BGX*PE
+ PY=PCY+BGY*PE
+ PZ=PCZ+BGZ*PE
+ P=SQRT(PX*PX+PY*PY+PZ*PZ)
+ E=GA*EC+EP
+
+ END
+
+*$ CREATE PHO_LTRANS.FOR
+*COPY PHO_LTRANS
+CDECK ID>, PHO_LTRANS
+ SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
+ & PL,CXL,CYL,CZL,EL)
+C**********************************************************************
+C
+C Lorentz transformation into lab - system
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ SID=SQRT(1.D0-COD*COD)
+ PLX=P*SID*COF
+ PLY=P*SID*SIF
+ PCMZ=P*COD
+ PLZ=GAM*PCMZ+BGAM*ECM
+ PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
+ EL=GAM*ECM+BGAM*PCMZ
+
+C rotation into the original direction
+ COZ=PLZ/PL
+ SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
+
+* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
+
+ AX=ABS(CX)
+ AY=ABS(CY)
+ IF(AX.LT.AY) THEN
+ AMAX=AY
+ AMIN=AX
+ ELSE
+ AMAX=AX
+ AMIN=AY
+ ENDIF
+ IF (ABS(CX)-TINY) 1,1,2
+ 1 IF (ABS(CY)-TINY) 3,3,2
+
+ 3 CONTINUE
+* WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
+ CXL=SIZ*COF
+ CYL=SIZ*SIF
+ CZL=COZ*CZ
+* WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
+* WRITE(LO,*) CXL,CYL,CZL
+ RETURN
+
+ 2 CONTINUE
+ IF(AMAX.GT.TINY2) THEN
+ AR=AMIN/AMAX
+ AR=AR*AR
+ A=AMAX*SQRT(1.D0+AR)
+ ELSE
+* WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
+ GOTO 3
+ ENDIF
+ XI=SIZ*COF
+ YI=SIZ*SIF
+ ZI=COZ
+ CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
+ CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
+ CZL=A*YI+CZ*ZI
+
+ END
+
+*$ CREATE PHO_TRANS.FOR
+*COPY PHO_TRANS
+CDECK ID>, PHO_TRANS
+ SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+C**********************************************************************
+C
+C rotation of coordinate frame (1) de rotation around y axis
+C (2) fe rotation around z axis
+C (inverse rotation to PHO_TRANI)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
+ Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
+ Z=-SDE *XO +CDE *ZO
+
+ END
+
+*$ CREATE PHO_TRANI.FOR
+*COPY PHO_TRANI
+CDECK ID>, PHO_TRANI
+ SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+C**********************************************************************
+C
+C rotation of coordinate frame (1) -fe rotation around z axis
+C (2) -de rotation around y axis
+C (inverse rotation to PHO_TRANS)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
+ Y=-SFE *XO+CFE* YO
+ Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
+
+ END
+
+*$ CREATE pho_cpcini.FOR
+*COPY pho_cpcini
+CDECK ID>, pho_cpcini
+ SUBROUTINE pho_cpcini(Nrows,Number,List)
+C***********************************************************************
+C
+C initialization of particle hash table
+C
+C input: Number vector with Nrows entries according to PDG
+C convention
+C
+C output: List vector with hash table
+C
+C (this code is based on the function initpns written by
+C Gerry Lynch, LBL, January 1990)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer Number(*),List(*),Nrows
+
+ Integer Nin,Nout,Ip,I
+
+ do I = 1,577
+ List(I) = 0
+ enddo
+
+C Loop over all of the elements in the Number vector
+
+ Do 500 Ip = 1,Nrows
+ Nin = Number(Ip)
+
+C Calculate a list number for this particle id number
+ If(Nin.Gt.99999.or.Nin.Le.0) Then
+ Nout = -1
+ Else If(Nin.Le.577) Then
+ Nout = Nin
+ Else
+ Nout = Mod(Nin,577)
+ End If
+
+ 200 continue
+
+ If(Nout.Lt.0) Then
+C Count the bad entries
+ WRITE(LO,'(1x,a,i10)')
+ & 'pho_cpcini: invalid particle ID',Nin
+ Go to 500
+ End If
+ If(List(Nout).eq.0) Then
+ List(Nout) = Ip
+ Else
+ If(Nin.eq.Number(List(Nout))) Then
+ WRITE(LO,'(1x,a,i10)')
+ & 'pho_cpcini: double particle ID',Nin
+ End If
+ Nout = Nout + 5
+ If(Nout.Gt.577) Nout = Mod(Nout, 577)
+
+ Go to 200
+ End If
+ 500 Continue
+
+ END
+
+*$ CREATE ipho_pdg2id.FOR
+*COPY ipho_pdg2id
+CDECK ID>, ipho_pdg2id
+ INTEGER FUNCTION ipho_pdg2id(IDpdg)
+C**********************************************************************
+C
+C calculation internal particle code using the particle index i
+C according to the PDG proposal.
+C
+C input: IDpdg PDG particle number
+C output: ipho_pdg2id internal particle code
+C (0 for invalid IDpdg)
+C
+C the hash algorithm is based on a program by Gerry Lynch
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer IDpdg
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+
+ integer Nin,Nout
+
+ Nin = abs(IDpdg)
+
+ if((Nin.gt.99999).or.(Nin.eq.0)) then
+C invalid particle number
+ if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
+ & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
+ ipho_pdg2id = 0
+ return
+ else If(Nin.le.577) then
+C simple case
+ Nout = Nin
+ else
+C use hash algorithm
+ Nout = mod(Nin,577)
+ endif
+
+ 100 continue
+
+C particle not in table
+ if(ID_list(Nout).Eq.0) then
+ if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
+ & 'ipho_pdg2id: particle not in table ',IDpdg
+ ipho_pdg2id = 0
+ return
+ endif
+
+ if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
+C particle ID found
+ ipho_pdg2id = sign(ID_list(Nout),IDpdg)
+ return
+ else
+C increment and try again
+ Nout = Nout + 5
+ If(Nout.gt.577) Nout = Mod(Nout,577)
+ goto 100
+ endif
+
+ END
+
+*$ CREATE IPHO_ID2PDG.FOR
+*COPY IPHO_ID2PDG
+CDECK ID>, IPHO_ID2PDG
+ INTEGER FUNCTION ipho_id2pdg(IDcpc)
+C**********************************************************************
+C
+C conversion of internal particle code to PDG standard
+C
+C input: IDcpc internal particle number
+C output: ipho_id2pdg PDG particle number
+C (0 for invalid IDcpc)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer IDcpc
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+
+ integer IDabs
+
+ IDabs = abs(IDcpc)
+ if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
+ ipho_id2pdg = 0
+ return
+ endif
+
+ ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
+
+ END
+
+*$ CREATE IPHO_LU2PDG.FOR
+*COPY IPHO_LU2PDG
+CDECK ID>, IPHO_LU2PDG
+ INTEGER FUNCTION IPHO_LU2PDG(LUKF)
+C**********************************************************************
+C
+C conversion of JETSET KF code to PDG code
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (NTAB=10)
+ DIMENSION LU2PD(2,NTAB)
+ DATA LU2PD / 4232, 4322,
+ & 4322, 4232,
+ & 3212, 3122,
+ & 3122, 3212,
+ & 30553, 20553,
+ & 30443, 20443,
+ & 20443, 10443,
+ & 10443, 0,
+ & 511, 0,
+ & 10551, 551 /
+C
+ DO 100 I=1,NTAB
+ IF(LU2PD(1,I).EQ.LUKF) THEN
+ IPHO_LU2PDG=LU2PD(2,I)
+ RETURN
+ ENDIF
+ 100 CONTINUE
+ IPHO_LU2PDG=LUKF
+
+ END
+
+*$ CREATE IPHO_PDG2LU.FOR
+*COPY IPHO_PDG2LU
+CDECK ID>, IPHO_PDG2LU
+ INTEGER FUNCTION IPHO_PDG2LU(IPDG)
+C**********************************************************************
+C
+C conversion of PDG code to JETSET code
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (NTAB=8)
+ DIMENSION LU2PD(2,NTAB)
+ DATA LU2PD / 4232, 4322,
+ & 4322, 4232,
+ & 3212, 3122,
+ & 3122, 3212,
+ & 30553, 20553,
+ & 30443, 20443,
+ & 20443, 10443,
+ & 10551, 551 /
+C
+ DO 100 I=1,NTAB
+ IF(LU2PD(2,I).EQ.IPDG) THEN
+ IPHO_PDG2LU=LU2PD(1,I)
+ RETURN
+ ENDIF
+ 100 CONTINUE
+ IPHO_PDG2LU=IPDG
+
+ END
+
+*$ CREATE pho_pname.FOR
+*COPY pho_pname
+CDECK ID>, pho_pname
+ CHARACTER*15 FUNCTION pho_pname(ID,mode)
+C***********************************************************************
+C
+C returns particle name for given ID number
+C
+C input: ID particle ID number
+C mode 0: ID treated as compressed particle code
+C 1: ID treated as PDG number
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_id2pdg,ipho_pdg2id
+
+C local variables
+ integer IDpdg,i,ii,k,l,ichar,i_anti
+ character*15 name
+
+ pho_pname = '(?????????????)'
+
+ if(mode.eq.0) then
+ i = ID
+ IDpdg = ipho_id2pdg(ID)
+ if(IDpdg.eq.0) return
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) then
+ if(ISTHEP(ID).eq.20) then
+ pho_pname = 'hard ini. part.'
+ else if(ISTHEP(ID).eq.21) then
+ pho_pname = 'hard fin. part.'
+ else if(ISTHEP(ID).eq.25) then
+ pho_pname = 'hard scattering'
+ else if(ISTHEP(ID).eq.30) then
+ pho_pname = 'diff. diss. '
+ else if(ISTHEP(ID).eq.35) then
+ pho_pname = 'elastic scatt. '
+ else if(ISTHEP(ID).eq.40) then
+ pho_pname = 'central scatt. '
+ endif
+ return
+ endif
+ IDpdg = IDHEP(ID)
+ i = IMPART(ID)
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
+ return
+ endif
+
+ ii = abs(i)
+ if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
+
+ name = name_list(ii)
+ ichar = ich3_list(ii)*sign(1,i)
+ if(mod(ichar,3).ne.0) then
+ ichar = 0
+ else
+ ichar = ichar/3
+ endif
+
+C find position of first blank character
+ k = 1
+ 100 continue
+ k = k+1
+ if(name(k:k).ne.' ') goto 100
+
+C append anti-particle sign
+ if(i.lt.0) then
+ i_anti = 0
+ do l=1,3
+ i_anti = i_anti+iq_list(l,ii)
+ enddo
+ if(iba3_list(ii).ne.0) then
+ name(k:k) = '~'
+ k = K+1
+ else if(((i_anti.ne.0).and.(ichar.eq.0))
+ & .or.(IDpdg.eq.-12)
+ & .or.(IDpdg.eq.-14)
+ & .or.(IDpdg.eq.-16)) then
+ name(k:k) = '~'
+ k = K+1
+ endif
+ endif
+
+C append charge sign
+ if(ichar.eq.-2) then
+ name(k:k+1) = '--'
+ else if(ichar.eq.-1) then
+ name(k:k) = '-'
+ else if(ichar.eq.1) then
+ name(k:k) = '+'
+ else if(ichar.eq.2) then
+ name(k:k+1) = '++'
+ endif
+
+ pho_pname = name
+
+ END
+
+*$ CREATE ipho_anti.FOR
+*COPY ipho_anti
+CDECK ID>, ipho_anti
+ INTEGER FUNCTION ipho_anti(ID)
+C**********************************************************************
+C
+C determine antiparticle for given ID
+C
+C input: ID gives CPC particle number
+C
+C output: ipho_anti antiparticle code
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C external functions
+ integer ipho_id2pdg,ipho_pdg2id
+
+C local variables
+ integer IDabs,IDpdg,i_anti,l
+
+ ipho_anti = -ID
+ IDabs = abs(ID)
+
+C baryons
+ if(iba3_list(IDabs).ne.0) return
+
+C charged particles
+ if(ich3_list(IDabs).ne.0) return
+
+C K0_s and K0_l
+ IDpdg = ipho_id2pdg(ID)
+ if(IDpdg.eq.310) then
+ ID = ipho_pdg2id(130)
+ return
+ else if(IDpdg.eq.130) then
+ ID = ipho_pdg2id(310)
+ return
+ endif
+
+C neutral mesons with open strangeness, charm, or beauty
+ i_anti = 0
+ do l=1,3
+ i_anti = i_anti+iq_list(l,IDabs)
+ enddo
+ if(i_anti.ne.0) return
+
+C neutrinos
+ IDpdg = abs(IDpdg)
+ if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
+
+ ipho_anti = ID
+
+ END
+
+*$ CREATE ipho_chr3.FOR
+*COPY ipho_chr3
+CDECK ID>, ipho_chr3
+ INTEGER FUNCTION ipho_chr3(ID,mode)
+C**********************************************************************
+C
+C output of three times the electric charge
+C
+C input: mode
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number
+C 2 ID gives position of particle in /POEVT1/
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_pdg2id
+
+C local variables
+ integer i,IDpdg
+
+ ipho_chr3 = 0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ ipho_chr3 = ICOLOR(1,ID)
+ return
+ endif
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,3i8)')
+ & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
+ ipho_chr3 = 1.D0/dble(i)
+ call pho_prevnt(0)
+ return
+ endif
+
+ ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
+
+ END
+
+*$ CREATE ipho_bar3.FOR
+*COPY ipho_bar3
+CDECK ID>, ipho_bar3
+ INTEGER FUNCTION ipho_bar3(ID,mode)
+C**********************************************************************
+C
+C output of three times the baryon charge
+C
+C index: MODE
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number
+C 2 ID gives position of particle in /POEVT1/
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_pdg2id
+
+C local variables
+ integer i,IDpdg
+
+ ipho_bar3 = 0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ ipho_bar3 = ICOLOR(2,ID)
+ return
+ endif
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,3i8)')
+ & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
+ ipho_bar3 = 1.D0/dble(i)
+ return
+ endif
+
+ ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
+
+ END
+
+*$ CREATE pho_pmass.FOR
+*COPY pho_pmass
+CDECK ID>, pho_pmass
+ DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
+C***********************************************************************
+C
+C particle mass
+C
+C input: mode -1 initialization
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number,
+C (for quarks current masses are returned)
+C 2 ID gives position of particle in /POEVT1/
+C 3 ID gives PDG parton number,
+C (for quarks constituent masses are returned)
+C
+C output: average particle mass (in GeV)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode,MSTJ24
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+C external functions
+ integer ipho_pdg2id,ipho_id2pdg
+
+ DOUBLE PRECISION PYMASS
+
+C local variables
+ integer i,IDpdg
+
+ pho_pmass = 0.D0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ pho_pmass = PHEP(5,ID)
+ return
+ endif
+ else if(mode.eq.3) then
+ i = abs(ID)
+ if((i.gt.0).and.(i.le.6)) then
+ pho_pmass = PARMDL(150+i)
+ return
+ else
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ endif
+ else if(mode.eq.-1) then
+C initialization: take masses for quarks and di-quarks from JETSET
+ MSTJ24 = MSTJ(24)
+ MSTJ(24) = 0
+ do i=1,22
+ IDpdg = ipho_id2pdg(i)
+
+ xm_list(i) = PYMASS(IDpdg)
+
+ enddo
+ MSTJ(24) = MSTJ24
+ return
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,2i8)')
+ & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
+ pho_pmass = 1.D0/dble(i)
+ return
+ endif
+
+ pho_pmass = xm_list(iabs(i))
+
+ END
+
+*$ CREATE PHO_MEMASS.FOR
+*COPY PHO_MEMASS
+CDECK ID>, PHO_MEMASS
+ SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
+C**********************************************************************
+C
+C determine meson masses corresponding to the input flavours
+C
+C input: I,J,K quark flavours (PDG convention)
+C
+C output: AMPS pseudo scalar meson mass
+C AMPS2 next possible two particle configuration
+C (two pseudo scalar mesons)
+C AMVE vector meson mass
+C AMVE2 next possible two particle configuration
+C (two vector mesons)
+C IPS,IVE meson numbers in CPC
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,IPS,IVE
+ double precision AMPS,AMPS2,AMVE,AMVE2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj
+
+ IF(I.GT.0) THEN
+ ii = I
+ jj = -J
+ ELSE
+ ii = J
+ jj = -I
+ ENDIF
+
+C particle ID's
+ IPS = id_psm_list(ii,jj)
+ IVE = id_vem_list(ii,jj)
+C masses
+ if(IPS.ne.0) then
+ AMPS = xm_list(iabs(IPS))
+ else
+ AMPS = 0.D0
+ endif
+ if(IVE.ne.0) then
+ AMVE = xm_list(iabs(IVE))
+ else
+ AMVE = 0.D0
+ endif
+
+C next possible two-particle configurations (add phase space)
+ AMPS2 = xm_psm2_list(ii,jj)*1.5D0
+ AMVE2 = xm_vem2_list(ii,jj)*1.1D0
+
+ END
+
+*$ CREATE PHO_BAMASS.FOR
+*COPY PHO_BAMASS
+CDECK ID>, PHO_BAMASS
+ SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
+C**********************************************************************
+C
+C determine baryon masses corresponding to the input flavours
+C
+C input: I,J,K quark flavours (PDG convention)
+C
+C output: AM8 octett baryon mass
+C AM82 next possible two particle configuration
+C (octett baryon and meson)
+C AM10 decuplett baryon mass
+C AM102 next possible two particle configuration
+C (decuplett baryon and meson,
+C baryon built up from first two quarks)
+C I8,I10 internal baryon numbers
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,K,I8,I10
+ double precision AM8,AM82,AM10,AM102
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk
+
+C find particle ID's
+ ii = iabs(I)
+ jj = iabs(J)
+ kk = iabs(K)
+ I8 = id_b8_list(ii,jj,kk)
+ I10 = id_b10_list(ii,jj,kk)
+
+C masses (if combination possible)
+ if(I8.ne.0) then
+ AM8 = xm_list(I8)
+ I8 = sign(I8,i)
+ else
+ AM8 = 0.D0
+ endif
+ if(I10.ne.0) then
+ AM10 = xm_list(I10)
+ I10 = sign(I10,i)
+ else
+ AM10 = 0.D0
+ endif
+
+C next possible two-particle configurations (add phase space)
+ AM82 = xm_b82_list(ii,jj,kk)*1.5D0
+ AM102 = xm_b102_list(ii,jj,kk)*1.1D0
+
+ END
+
+*$ CREATE PHO_DQMASS.FOR
+*COPY PHO_DQMASS
+CDECK ID>, PHO_DQMASS
+ SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
+C**********************************************************************
+C
+C determine minimal masses corresponding to the input flavours
+C (diquark a-diquark string system)
+C
+C input: I,J,K,L quark flavours (PDG convention)
+C
+C output: AM82 mass of two octett baryons
+C AM102 mass of two decuplett baryons
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,K,L
+ double precision AM82,AM102
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk,ll
+
+ ii = iabs(i)
+ kk = iabs(k)
+ jj = iabs(j)
+ ll = iabs(l)
+
+ AM82 = xm_bb82_list(ii,jj,kk,ll)
+ AM102 = xm_bb102_list(ii,jj,kk,ll)
+
+ END
+
+*$ CREATE PHO_CHECK.FOR
+*COPY PHO_CHECK
+CDECK ID>, PHO_CHECK
+ SUBROUTINE PHO_CHECK(MD,IDEV)
+C**********************************************************************
+C
+C check quantum numbers of entries in /POEVT1/ and /POEVT2/
+C (energy, momentum, charge, baryon number conservation)
+C
+C input: MD -1 check overall momentum conservation
+C and perform detailed check only in case of
+C deviations
+C 1 test all branchings, mother-daughter
+C relations
+C
+C output: IDEV 0 no deviations
+C 1 deviations found
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+C count number of errors to avoid disk overflow
+ DATA IERR / 0 /
+
+ IDEV = 0
+C conservation check suppressed
+ IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
+
+ IF(IPAMDL(13).GT.0) THEN
+
+C DPMJET call with x limitations
+ MODE = -1
+ ECM1 = SQRT(XPSUB*XTSUB)*ECM
+
+ ELSE
+
+C standard call
+ MODE = MD
+C first two entries are considered as scattering particles
+ EE1 = PHEP(4,1) + PHEP(4,2)
+ PX1 = PHEP(1,1) + PHEP(1,2)
+ PY1 = PHEP(2,1) + PHEP(2,2)
+ PZ1 = PHEP(3,1) + PHEP(3,2)
+
+ ENDIF
+
+ DDREL = PARMDL(75)
+ DDABS = PARMDL(76)
+ IF(MODE.EQ.-1) GOTO 500
+
+ 50 CONTINUE
+
+ I = 1
+ 100 CONTINUE
+
+C recognize only decayed particles as mothers
+ IF(ISTHEP(I).EQ.2) THEN
+C search for other mother particles
+ K = JDAHEP(1,I)
+ IF(K.EQ.0) THEN
+ IF(IPAMDL(178).NE.0)
+ & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
+ & 'entry marked as decayed but no dauther given:',I
+ GOTO 99
+ ENDIF
+ K1 = JMOHEP(1,K)
+ K2 = JMOHEP(2,K)
+C sum over mother particles
+ ICH1 = IPHO_CHR3(K1,2)
+ IBA1 = IPHO_BAR3(K1,2)
+ EE1 = PHEP(4,K1)
+ PX1 = PHEP(1,K1)
+ PY1 = PHEP(2,K1)
+ PZ1 = PHEP(3,K1)
+ IF(K2.LT.0) THEN
+ K2 = -K2
+ IF((K1.GT.I).OR.(K2.LT.I)) THEN
+ WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
+ & 'inconsistent mother/daughter relation found',I,K1,K2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ DO 400 II=K1+1,K2
+ IF(ABS(ISTHEP(II)).LE.2) THEN
+ ICH1 = ICH1 + IPHO_CHR3(II,2)
+ IBA1 = IBA1 + IPHO_BAR3(II,2)
+ EE1 = EE1 + PHEP(4,II)
+ PX1 = PX1 + PHEP(1,II)
+ PY1 = PY1 + PHEP(2,II)
+ PZ1 = PZ1 + PHEP(3,II)
+ ENDIF
+ 400 CONTINUE
+ ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
+ ICH1 = ICH1 + IPHO_CHR3(K2,2)
+ IBA1 = IBA1 + IPHO_BAR3(K2,2)
+ EE1 = EE1 + PHEP(4,K2)
+ PX1 = PX1 + PHEP(1,K2)
+ PY1 = PY1 + PHEP(2,K2)
+ PZ1 = PZ1 + PHEP(3,K2)
+ ENDIF
+
+C sum over daughter particles
+ ICH2 = 0.D0
+ IBA2 = 0.D0
+ EE2 = 0.D0
+ PX2 = 0.D0
+ PY2 = 0.D0
+ PZ2 = 0.D0
+ DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
+ IF(ABS(ISTHEP(II)).LE.2) THEN
+ ICH2 = ICH2 + IPHO_CHR3(II,2)
+ IBA2 = IBA2 + IPHO_BAR3(II,2)
+ EE2 = EE2 + PHEP(4,II)
+ PX2 = PX2 + PHEP(1,II)
+ PY2 = PY2 + PHEP(2,II)
+ PZ2 = PZ2 + PHEP(3,II)
+ ENDIF
+ 200 CONTINUE
+
+C conservation check
+ ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
+ IF(ABS(EE1-EE2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
+ & 'PHO_CHECK: energy conservation violated for',
+ & 'entry,initial,final:',I,EE1,EE2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
+ IF(ABS(PX1-PX2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: x-momentum conservation violated for',
+ & 'entry,initial,final:',I,PX1,PX2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
+ IF(ABS(PY1-PY2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: y-momentum conservation violated for',
+ & 'entry,initial,final:',I,PY1,PY2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
+ IF(ABS(PZ1-PZ2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: z-momentum conservation violated for',
+ & 'entry,initial,final:',I,PZ1,PZ2
+ IDEV = 1
+ ENDIF
+ IF(ICH1.NE.ICH2) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
+ & 'PHO_CHECK: charge conservation violated for',
+ & 'entry,initial,final:',I,ICH1,ICH2
+ IDEV = 1
+ ENDIF
+ IF(IBA1.NE.IBA2) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
+ & 'baryon charge conservation violated for',
+ & 'entry,initial,final:',I,IBA1,IBA2
+ IDEV = 1
+ ENDIF
+ IF(IDEB(20).GE.35) THEN
+ WRITE(LO,
+ & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
+ & 'PHO_CHECK diagnostics:',
+ & '(1.mother/l.mother,1.daughter/l.daughter):',
+ & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
+ & 'mother momenta ',PX1,PY1,PZ1,EE1,
+ & 'daughter momenta ',PX2,PY2,PZ2,EE2,
+ & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
+ ENDIF
+ ENDIF
+ 99 CONTINUE
+ I = I+1
+ IF(I.LE.NHEP) GOTO 100
+
+ 55 CONTINUE
+
+ IERR = IERR+IDEV
+
+C write complete event in case of deviations
+ IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
+ CALL PHO_PREVNT(1)
+ IF(ISTR.GT.0) THEN
+ CALL PHO_PRSTRG
+
+ IF(ISWMDL(6).GE.0) CALL PYLIST(1)
+
+ ENDIF
+ ENDIF
+
+C stop after too many errors
+ IF(IERR.GT.IPAMDL(179)) THEN
+ WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
+ & 'too many inconsistencies found, program terminated',IERR
+ CALL PHO_ABORT
+ ENDIF
+
+ RETURN
+
+C overall check only (less time consuming)
+
+ 500 CONTINUE
+
+ ICH2 = 0.D0
+ IBA2 = 0.D0
+ EE2 = 0.D0
+ PX2 = 0.D0
+ PY2 = 0.D0
+ PZ2 = 0.D0
+
+ DO 300 K=3,NHEP
+C recognize only existing particles as possible daughters
+ IF(ABS(ISTHEP(K)).EQ.1) THEN
+ ICH2 = ICH2 + IPHO_CHR3(K,2)
+ IBA2 = IBA2 + IPHO_BAR3(K,2)
+ EE2 = EE2 + PHEP(4,K)
+ PX2 = PX2 + PHEP(1,K)
+ PY2 = PY2 + PHEP(2,K)
+ PZ2 = PZ2 + PHEP(3,K)
+ ENDIF
+ 300 CONTINUE
+
+C check energy-momentum conservation
+ ESC = ECM*DDREL
+
+ IF(IPAMDL(13).GT.0) THEN
+
+C DPMJET call with x limitations
+ ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
+ IF(ABS(ECM1-ECM2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: c.m. energy conservation violated',
+ & 'initial/final energy:',ECM1,ECM2
+ IDEV = 1
+ ENDIF
+
+ ELSE
+
+C standard call
+ IF(ABS(EE1-EE2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: energy conservation violated',
+ & 'initial/final energy:',EE1,EE2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PX1-PX2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: x-momentum conservation violated',
+ & 'initial/final x-momentum:',PX1,PX2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PY1-PY2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: y-momentum conservation violated',
+ & 'initial/final y-momentum:',PY1,PY2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PZ1-PZ2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: z-momentum conservation violated',
+ & 'initial/final z-momentum:',PZ1,PZ2
+ IDEV = 1
+ ENDIF
+
+C check of quantum number conservation
+
+ ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
+ IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
+
+ IF(ICH1.NE.ICH2) THEN
+ WRITE(LO,'(1X,A,/,5X,A,2I5)')
+ & 'PHO_CHECK: charge conservation violated',
+ & 'initial/final charge sum',ICH1,ICH2
+ IDEV = 1
+ ENDIF
+ IF(IBA1.NE.IBA2) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
+ & 'baryonic charge conservation violated',
+ & 'initial/final baryonic charge sum',IBA1,IBA2
+ IDEV = 1
+ ENDIF
+
+ ENDIF
+
+C perform detailed checks in case of deviations
+ IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
+ IF(IPAMDL(13).GT.0) THEN
+ GOTO 55
+ ELSE
+ DDREL = DDREL/2.D0
+ DDABS = DDABS/2.D0
+ WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
+ & 'increasing precision of tests to',DDREL,DDABS
+ GOTO 50
+ ENDIF
+ ENDIF
+
+ END
+
+*$ CREATE PHO_ABORT.FOR
+*COPY PHO_ABORT
+CDECK ID>, PHO_ABORT
+ SUBROUTINE PHO_ABORT
+C**********************************************************************
+C
+C top MC event generation due to fatal error,
+C print all information of event generation and history
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+ WRITE(LO,'(//,1X,A,/,1X,A)')
+ & 'PHO_ABORT: program execution stopped',
+ & '===================================='
+ WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
+C
+ CALL PHO_SETMDL(0,0,-2)
+ CALL PHO_PREVNT(-1)
+ CALL PHO_ACTPDF(0,-2)
+C print selected parton flavours
+ WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
+ DO 700 I=1,KSOFT
+ WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
+ 700 CONTINUE
+ WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
+ DO 750 K=1,KHARD
+ I = LSIDX(K)
+ WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
+ WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
+ & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
+ 750 CONTINUE
+C print selected parton momenta
+ WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
+ DO 300 I=1,KSOFT
+ WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
+ WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
+ 300 CONTINUE
+ WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
+ DO 350 K=1,KHARD
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
+ WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
+ 350 CONTINUE
+
+C print /POEVT1/
+ CALL PHO_PREVNT(0)
+
+C fragmentation process
+ IF(ISTR.GT.0) THEN
+C print /POSTRG/
+ CALL PHO_PRSTRG
+
+ IF(ISWMDL(6).GE.0) CALL PYLIST(1)
+
+ ENDIF
+
+C last message
+ WRITE(LO,'(////5X,A,///5X,A,///)')
+ & 'PHO_ABORT: execution terminated due to fatal error',
+ &'*** Simulating division by zero to get traceback information ***'
+ ISTR = 100/IPAMDL(100)
+
+ END
+
+*$ CREATE PHO_TRACE.FOR
+*COPY PHO_TRACE
+CDECK ID>, PHO_TRACE
+ SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
+C**********************************************************************
+C
+C trace program subroutines according to level,
+C original output levels will be saved
+C
+C input: ISTART first event to trace
+C ISWI number of events to trace
+C 0 loop call, use old values
+C -1 restore original output levels
+C 1 store level and wait for event
+C LEVEL desired output level
+C 0 standard output
+C 3 internal rejections
+C 5 cross sections, slopes etc.
+C 10 parameter of subroutines and
+C results
+C 20 huge amount of debug output
+C 30 maximal possible output
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+ DIMENSION IMEM(NMAXD)
+
+C protect ISWI
+ ISW = ISWI
+ 10 CONTINUE
+ IF(ISW.EQ.0) THEN
+ IF(KEVENT.LT.ION) THEN
+ RETURN
+ ELSE IF(KEVENT.EQ.ION) THEN
+ WRITE(LO,'(///,1X,A,///)')
+ & 'PHO_TRACE: trace mode switched on'
+ DO 100 I=1,NMAXD
+ IMEM(I) = IDEB(I)
+ IDEB(I) = MAX(ILEVEL,IMEM(I))
+ 100 CONTINUE
+ ELSE IF(KEVENT.EQ.IOFF) THEN
+ WRITE(LO,'(//,1X,A,///)')
+ & 'PHO_TRACE: trace mode switched off'
+ DO 200 I=1,NMAXD
+ IDEB(I) = IMEM(I)
+ 200 CONTINUE
+ ENDIF
+ ELSE IF(ISW.EQ.-1) THEN
+ DO 300 I=1,NMAXD
+ IDEB(I) = IMEM(I)
+ 300 CONTINUE
+ ELSE
+C save information
+ ION = ISTART
+ IOFF = ISTART+ISW
+ ILEVEL = LEVEL
+ ENDIF
+C check coincidence
+ IF(ISW.GT.0) THEN
+ ISW=0
+ ILEVEL = LEVEL
+ GOTO 10
+ ENDIF
+
+ END
+
+*$ CREATE PHO_PRSTRG.FOR
+*COPY PHO_PRSTRG
+CDECK ID>, PHO_PRSTRG
+ SUBROUTINE PHO_PRSTRG
+C**********************************************************************
+C
+C print information of /POSTRG/
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C color string configurations including collapsed strings and hadrons
+ INTEGER MSTR
+ PARAMETER (MSTR=500)
+ INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+ COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+ & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+ & NNCH(MSTR),IBHAD(MSTR),ISTR
+
+ WRITE(LO,'(/,1X,A,I5)')
+ & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
+ WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
+ & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
+ WRITE(LO,'(1X,A)')
+ & ' ======================================================='
+ DO 800 I=1,ISTR
+ WRITE(LO,'(1X,9I5,1P,E11.3)')
+ & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
+ & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
+ 800 CONTINUE
+
+ END
+
+*$ CREATE PHO_PREVNT.FOR
+*COPY PHO_PREVNT
+CDECK ID>, PHO_PREVNT
+ SUBROUTINE PHO_PREVNT(NPART)
+C**********************************************************************
+C
+C print all information of event generation and history
+C
+C input: NPART -1 minimal output: process IDs
+C 0 additional output of /POEVT1/
+C 1 additional output of /POSTRG/
+C 2 additional output of /HEPEVT/
+C (call LULIST(1))
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+
+ CHARACTER*15 PHO_PNAME
+
+ IF(NPART.GE.0) WRITE(LO,'(/)')
+ WRITE(LO,'(1X,A,1PE10.3)')
+ & 'PHO_PREVNT: c.m. energy',ECM
+ CALL PHO_SETPAR(-2,IH,NPART,0.D0)
+ WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
+ & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
+ & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
+ & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
+ & KHDPO
+ WRITE(LO,'(6X,A,I4,4I3)')
+ & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
+ & IDIFR2,IDDPOM
+
+ IF(IPAMDL(13).GT.0) THEN
+ WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
+ & ECMN,PCMN,SECM,SPCM
+ WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
+ ENDIF
+
+ IF(NPART.LT.0) RETURN
+
+ IF(NPART.GE.1) CALL PHO_PRSTRG
+
+ WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
+ ICHAS = 0
+ IBARFS = 0
+ IMULC = 0
+ IMUL = 0
+ WRITE(LO,'(/1X,A,A,/,1X,A,A)')
+ & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
+ & ' IH1 IH2 CO1 CO2',
+ & '========================================================',
+ & '===================='
+ DO 20 IH=1,NHEP
+ CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
+ BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
+ WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
+ & IH,ISTHEP(IH),PHO_PNAME(IH,2),
+ & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
+ & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
+ & ICOLOR(1,IH),ICOLOR(2,IH)
+ IF(ABS(ISTHEP(IH)).EQ.1) THEN
+ ICHAS = ICHAS + IPHO_CHR3(IH,2)
+ IBARFS = IBARFS + IPHO_BAR3(IH,2)
+ ENDIF
+ IF(ABS(ISTHEP(IH)).EQ.1) THEN
+ IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
+ IMUL = IMUL+1
+ ENDIF
+ 20 CONTINUE
+ WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
+ & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
+
+ WRITE(LO,7)
+ PXS = 0.D0
+ PYS = 0.D0
+ PZS = 0.D0
+ P0S = 0.D0
+ DO 30 IN=1,NHEP
+ IF( (ABS(PHEP(3,IN)).LT.99999.D0)
+ & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
+ WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
+ & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
+ ELSE
+ WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
+ & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
+ ENDIF
+ IF(ABS(ISTHEP(IN)).EQ.1) THEN
+ PXS = PXS + PHEP(1,IN)
+ PYS = PYS + PHEP(2,IN)
+ PZS = PZS + PHEP(3,IN)
+ P0S = P0S + PHEP(4,IN)
+ ENDIF
+ 30 CONTINUE
+ AMFS = P0S**2-PXS**2-PYS**2-PZS**2
+ AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
+ IF(P0S.LT.99999.D0) THEN
+ WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
+ ELSE
+ WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
+ ENDIF
+ WRITE(LO,'(//)')
+
+ 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
+ & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
+ & 8H CHARGE ,8H BARYON ,/)
+ 6 FORMAT(7I8,2F8.3)
+ 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
+ & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
+ & 2X,'-------------------------------',
+ & '--------------------------------------------')
+ 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
+ 9 FORMAT(I10,14X,5F10.3)
+ 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
+ 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
+ 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
+
+ IF(NPART.GE.2) CALL PYLIST(1)
+
+ END
+
+*$ CREATE PHO_LTRHEP.FOR
+*COPY PHO_LTRHEP
+CDECK ID>, PHO_LTRHEP
+ SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
+C*******************************************************************
+C
+C Lorentz transformation of entries I1 to I2 in /POEVT1/
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DIFF = 0.001D0,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+C standard particle data interface
+ INTEGER NMXHEP
+
+ PARAMETER (NMXHEP=4000)
+
+ INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+ DOUBLE PRECISION PHEP,VHEP
+ COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+ & VHEP(4,NMXHEP)
+C extension to standard particle data interface (PHOJET specific)
+ INTEGER IMPART,IPHIST,ICOLOR
+ COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+
+ DO 100 I=I1,MIN(I2,NHEP)
+ IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
+ CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ EE=PHEP(4,I)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
+ ELSE IF(ISTHEP(I).EQ.20) THEN
+ EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
+ CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
+ ENDIF
+ 100 CONTINUE
+
+C debug precision
+ IF(IDEB(70).LT.1) RETURN
+ DO 200 I=I1,MIN(NHEP,I2)
+ IF(ABS(ISTHEP(I)).GT.10) GOTO 190
+ PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
+ PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
+ IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
+ WRITE(LO,'(1X,A,I5,2E13.4)')
+ & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
+ ENDIF
+ 190 CONTINUE
+ 200 CONTINUE
+
+ END
+
+*$ CREATE PHO_PECMS.FOR
+*COPY PHO_PECMS
+CDECK ID>, PHO_PECMS
+ SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
+C*******************************************************************
+C
+C calculation of cms momentum and energy of massive particle
+C (ID= 1 using PMASS1, 2 using PMASS2)
+C
+C output: PP cms momentum
+C EE energy in CMS of particle ID
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ S=ECM**2
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
+ & + PM1**2 + PM2**2)/(2.D0*ECM)
+
+ IF(ID.EQ.1) THEN
+ EE = SQRT( PM1 + PP**2 )
+ ELSE IF(ID.EQ.2) THEN
+ EE = SQRT( PM2 + PP**2 )
+ ELSE
+ WRITE(LO,'(/1X,A,I3,/)')
+ & 'PHO_PECMS:ERROR: invalid ID number:',ID
+ EE = PP
+ ENDIF
+
+ END
+
+*$ CREATE PHO_FRAINI.FOR
+*COPY PHO_FRAINI
+CDECK ID>, PHO_FRAINI
+ SUBROUTINE PHO_FRAINI(IDEFAU)
+C***********************************************************************
+C
+C initialization of fragmentation packages
+C (currently LUND JETSET)
+C
+C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
+C changed to work in PHOJET (R.E. 1/94)
+C
+C input: IDEFAU 0 no hadronization at all
+C 1 do not touch any parameter of JETSET
+C 2 default parameters kept, decay length 10mm to
+C define stable particles
+C 3 load tuned parameters for JETSET 7.3
+C neg. value: prevent strange/charm hadrons from decaying
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS=1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER KCHG
+ DOUBLE PRECISION PMAS,PARF,VCKM
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+ INTEGER PYCOMP
+
+ IDEFAB = ABS(IDEFAU)
+
+ IF(IDEFAB.EQ.0) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
+ RETURN
+ ENDIF
+C defaults
+ DEF2 = PARJ(2)
+ IDEF12 = MSTJ(12)
+ DEF19 = PARJ(19)
+ DEF41 = PARJ(41)
+ DEF42 = PARJ(42)
+ DEF21 = PARJ(21)
+
+C declare stable particles
+ IF(IDEFAB.GE.2) MSTJ(22) = 2
+
+C load optimized parameters
+ IF(IDEFAB.GE.3) THEN
+
+* PARJ(19)=0.19
+C Lund a-parameter
+C (default=0.3)
+ PARJ(41)=0.3
+C Lund b-parameter
+C (default=1.0)
+ PARJ(42)=1.0
+C Lund sigma parameter in pt distribution
+C (default=0.36)
+ PARJ(21)=0.36
+ ENDIF
+C
+C prevent particles decaying
+ IF(IDEFAU.LT.0) THEN
+C K0S
+
+ KC=PYCOMP(310)
+
+ MDCY(KC,1)=0
+C PI0
+
+ KC=PYCOMP(111)
+
+ MDCY(KC,1)=0
+C LAMBDA
+
+ KC=PYCOMP(3122)
+
+ MDCY(KC,1)=0
+C ALAMBDA
+
+ KC=PYCOMP(-3122)
+
+ MDCY(KC,1)=0
+C SIG+
+
+ KC=PYCOMP(3222)
+
+ MDCY(KC,1)=0
+C ASIG+
+
+ KC=PYCOMP(-3222)
+
+ MDCY(KC,1)=0
+C SIG-
+
+ KC=PYCOMP(3112)
+
+ MDCY(KC,1)=0
+C ASIG-
+
+ KC=PYCOMP(-3112)
+
+ MDCY(KC,1)=0
+C SIG0
+
+ KC=PYCOMP(3212)
+
+ MDCY(KC,1)=0
+C ASIG0
+
+ KC=PYCOMP(-3212)
+
+ MDCY(KC,1)=0
+C TET0
+
+ KC=PYCOMP(3322)
+
+ MDCY(KC,1)=0
+C ATET0
+
+ KC=PYCOMP(-3322)
+
+ MDCY(KC,1)=0
+C TET-
+
+ KC=PYCOMP(3312)
+
+ MDCY(KC,1)=0
+C ATET-
+
+ KC=PYCOMP(-3312)
+
+ MDCY(KC,1)=0
+C OMEGA-
+
+ KC=PYCOMP(3334)
+
+ MDCY(KC,1)=0
+C AOMEGA-
+
+ KC=PYCOMP(-3334)
+
+ MDCY(KC,1)=0
+C D+
+
+ KC=PYCOMP(411)
+
+ MDCY(KC,1)=0
+C D-
+
+ KC=PYCOMP(-411)
+
+ MDCY(KC,1)=0
+C D0
+
+ KC=PYCOMP(421)
+
+ MDCY(KC,1)=0
+C A-D0
+
+ KC=PYCOMP(-421)
+
+ MDCY(KC,1)=0
+C DS+
+
+ KC=PYCOMP(431)
+
+ MDCY(KC,1)=0
+C A-DS+
+
+ KC=PYCOMP(-431)
+
+ MDCY(KC,1)=0
+C ETAC
+
+ KC=PYCOMP(441)
+
+ MDCY(KC,1)=0
+C LAMBDAC+
+
+ KC=PYCOMP(4122)
+
+ MDCY(KC,1)=0
+C A-LAMBDAC+
+
+ KC=PYCOMP(-4122)
+
+ MDCY(KC,1)=0
+C SIGMAC++
+
+ KC=PYCOMP(4222)
+
+ MDCY(KC,1)=0
+C SIGMAC+
+
+ KC=PYCOMP(4212)
+
+ MDCY(KC,1)=0
+C SIGMAC0
+
+ KC=PYCOMP(4112)
+
+ MDCY(KC,1)=0
+C A-SIGMAC++
+
+ KC=PYCOMP(-4222)
+
+ MDCY(KC,1)=0
+C A-SIGMAC+
+
+ KC=PYCOMP(-4212)
+
+ MDCY(KC,1)=0
+C A-SIGMAC0
+
+ KC=PYCOMP(-4112)
+
+ MDCY(KC,1)=0
+C KSIC+
+
+ KC=PYCOMP(4232)
+
+ MDCY(KC,1)=0
+C KSIC0
+
+ KC=PYCOMP(4132)
+
+ MDCY(KC,1)=0
+C A-KSIC+
+
+ KC=PYCOMP(-4232)
+
+ MDCY(KC,1)=0
+C A-KSIC0
+
+ KC=PYCOMP(-4132)
+
+ MDCY(KC,1)=0
+ ENDIF
+
+ WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
+ & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
+ 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
+ & ' --------------------------------------------------',/,
+ & 5X,'parameter description default / current',/,
+ & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
+ & 5X,'MSTJ(12) popcorn : ',2I7,/,
+ & 5X,'PARJ(19) popcorn : ',2F7.3,/,
+ & 5X,'PARJ(41) Lund a : ',2F7.3,/,
+ & 5X,'PARJ(42) Lund b : ',2F7.3,/,
+ & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
+
+ END
+
+*$ CREATE PHO_SETPAR.FOR
+*COPY PHO_SETPAR
+CDECK ID>, PHO_SETPAR
+ SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
+C**********************************************************************
+C
+C assign a particle to either side 1 or 2
+C (including special treatment for remnants)
+C
+C input: Iside 1,2 side selected for the particle
+C -2 output of current settings
+C IDpdg PDG number
+C IDcpc CPC number
+C 0 CPC determination in subroutine
+C -1 special particle remnant, IDPDG
+C is the particle number the remnant
+C corresponds to (see /POHDFL/)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer Iside,IDpdg,IDcpc
+ double precision Pvir
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C event debugging information
+ INTEGER NMAXD
+ PARAMETER (NMAXD=100)
+ INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+ & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+ COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+ & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C global event kinematics and particle IDs
+ INTEGER IFPAP,IFPAB
+ DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+ COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C nucleon-nucleus / nucleus-nucleus interface to DPMJET
+ INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+ DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+ COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+ & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+C external functions
+ integer ipho_pdg2id,ipho_chr3,ipho_bar3
+ double precision pho_pmass
+
+C local variables
+ integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
+
+ IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
+ IDcpcN = IDcpc
+C remnant?
+ IF(IDcpc.EQ.-1) THEN
+ IF(Iside.EQ.1) THEN
+ IDpdgR = 81
+ ELSE
+ IDpdgR = 82
+ ENDIF
+ IDcpcR = ipho_pdg2id(IDpdgR)
+ IDEQB(Iside) = ipho_pdg2id(IDpdg)
+ IDEQP(Iside) = IDpdg
+C copy particle properties
+ IDB = abs(IDEQB(Iside))
+ xm_list(IDcpcR) = xm_list(IDB)
+ tau_list(IDcpcR) = tau_list(IDB)
+ gam_list(IDcpcR) = gam_list(IDB)
+ IF(IHFLS(Iside).EQ.1) THEN
+ ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
+ iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
+ ELSE
+ ich3_list(IDcpcR) = 0
+ iba3_list(IDcpcR) = 0
+ ENDIF
+C quark content
+ IFL1 = IHFLD(Iside,1)
+ IFL2 = IHFLD(Iside,2)
+ IFL3 = 0
+ IF(IHFLS(Iside).EQ.1) THEN
+ IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
+ IFL1 = IHFLD(Iside,1)/1000
+ IFL2 = MOD(IHFLD(Iside,1)/100,10)
+ IFL3 = IHFLD(Iside,2)
+ ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
+ IFL1 = IHFLD(Iside,1)
+ IFL2 = IHFLD(Iside,2)/1000
+ IFL3 = MOD(IHFLD(Iside,2)/100,10)
+ ENDIF
+ ENDIF
+ iq_list(1,IDcpcR) = IFL1
+ iq_list(2,IDcpcR) = IFL2
+ iq_list(3,IDcpcR) = IFL3
+
+ IDcpcN = IDcpcR
+ IDPDGN = IDPDGR
+
+ IF(IDEB(87).GE.5) THEN
+ WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
+ & 'pho_setpar: remnant assignment side',Iside,
+ & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
+ ENDIF
+ ELSE IF(IDcpc.EQ.0) THEN
+C ordinary hadron
+ IHFLS(Iside) = 1
+ IHFLD(Iside,1) = 0
+ IHFLD(Iside,2) = 0
+ IDcpcN = ipho_pdg2id(IDpdg)
+ IDpdgN = IDpdg
+ ENDIF
+
+C initialize /POGCMS/
+ IFPAP(Iside) = IDpdgN
+ IFPAB(Iside) = IDcpcN
+ PMASS(Iside) = pho_pmass(IDcpcN,0)
+ IF(IFPAP(Iside).EQ.22) THEN
+ PVIRT(Iside) = ABS(PVIR)
+ ELSE
+ PVIRT(Iside) = 0.D0
+ ENDIF
+
+ ELSE IF(Iside.EQ.-2) THEN
+C output of current settings
+ DO 100 I=1,2
+ WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
+ & 'PHO_SETPAR: side',
+ & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
+ & PVIRT(I)
+ IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
+ WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
+ & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
+ & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
+ ENDIF
+ 100 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I8)')
+ & 'pho_setpar: invalid argument (Iside)',Iside
+ ENDIF
+
+ END
+
+*$ CREATE PHO_XLAM.FOR
+*COPY PHO_XLAM
+CDECK ID>, PHO_XLAM
+ DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
+C**********************************************************************
+C
+C auxiliary function for two/three particle decay mode
+C (standard LAMBDA**(1/2) function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ YZ=Y-Z
+ XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
+ IF(XLAM.LT.0.D0) XLAM=-XLAM
+ PHO_XLAM=SQRT(XLAM)
+ END
+
+*$ CREATE PHO_BESSJ0.FOR
+*COPY PHO_BESSJ0
+CDECK ID>, PHO_BESSJ0
+ DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
+C**********************************************************************
+C
+C CERN (KERN) LIB function C312
+C
+C modified by R. Engel (03/02/93)
+C
+C**********************************************************************
+ DOUBLE PRECISION DX
+ DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
+ DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
+ SAVE
+
+ DATA EIGHT /8.0D0/
+ DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
+
+ DATA C1( 0) /+0.15772 79714 7489D0/
+ DATA C1( 1) /-0.00872 34423 5285D0/
+ DATA C1( 2) /+0.26517 86132 0334D0/
+ DATA C1( 3) /-0.37009 49938 7265D0/
+ DATA C1( 4) /+0.15806 71023 3210D0/
+ DATA C1( 5) /-0.03489 37694 1141D0/
+ DATA C1( 6) /+0.00481 91800 6947D0/
+ DATA C1( 7) /-0.00046 06261 6621D0/
+ DATA C1( 8) /+0.00003 24603 2882D0/
+ DATA C1( 9) /-0.00000 17619 4691D0/
+ DATA C1(10) /+0.00000 00760 8164D0/
+ DATA C1(11) /-0.00000 00026 7925D0/
+ DATA C1(12) /+0.00000 00000 7849D0/
+ DATA C1(13) /-0.00000 00000 0194D0/
+ DATA C1(14) /+0.00000 00000 0004D0/
+
+ DATA C2( 0) /+0.99946 03493 4752D0/
+ DATA C2( 1) /-0.00053 65220 4681D0/
+ DATA C2( 2) /+0.00000 30751 8479D0/
+ DATA C2( 3) /-0.00000 00517 0595D0/
+ DATA C2( 4) /+0.00000 00016 3065D0/
+ DATA C2( 5) /-0.00000 00000 7864D0/
+ DATA C2( 6) /+0.00000 00000 0517D0/
+ DATA C2( 7) /-0.00000 00000 0043D0/
+ DATA C2( 8) /+0.00000 00000 0004D0/
+ DATA C2( 9) /-0.00000 00000 0001D0/
+
+ DATA C3( 0) /-0.01555 58546 05337D0/
+ DATA C3( 1) /+0.00006 83851 99426D0/
+ DATA C3( 2) /-0.00000 07414 49841D0/
+ DATA C3( 3) /+0.00000 00179 72457D0/
+ DATA C3( 4) /-0.00000 00007 27192D0/
+ DATA C3( 5) /+0.00000 00000 42201D0/
+ DATA C3( 6) /-0.00000 00000 03207D0/
+ DATA C3( 7) /+0.00000 00000 00301D0/
+ DATA C3( 8) /-0.00000 00000 00033D0/
+ DATA C3( 9) /+0.00000 00000 00004D0/
+ DATA C3(10) /-0.00000 00000 00001D0/
+
+ X=DX
+ V=ABS(X)
+ IF(V .LT. EIGHT) THEN
+ Y=V/EIGHT
+ H=2.D0*Y**2-1.D0
+ ALFA=-2.D0*H
+ B1=0.D0
+ B2=0.D0
+ DO 1 I = 14,0,-1
+ B0=C1(I)-ALFA*B1-B2
+ B2=B1
+ 1 B1=B0
+ B1=B0-H*B2
+ ELSE
+ R=1.D0/V
+ Y=EIGHT*R
+ H=2.D0*Y**2-1.D0
+ ALFA=-2.D0*H
+ B1=0.D0
+ B2=0.D0
+ DO 2 I = 9,0,-1
+ B0=C2(I)-ALFA*B1-B2
+ B2=B1
+ 2 B1=B0
+ P=B0-H*B2
+ B1=0.D0
+ B2=0.D0
+ DO 3 I = 10,0,-1
+ B0=C3(I)-ALFA*B1-B2
+ B2=B1
+ 3 B1=B0
+ Q=Y*(B0-H*B2)
+ B0=V-PI2
+ B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
+ ENDIF
+ PHO_BESSJ0=B1
+ RETURN
+ END
+
+*$ CREATE PHO_BESSI0.FOR
+*COPY PHO_BESSI0
+CDECK ID>, PHO_BESSI0
+ DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
+C**********************************************************************
+C
+C Bessel Function I0
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ PHO_BESSI0 =
+ & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
+ & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
+ ELSE
+ Y = 3.75D0/AX
+ PHO_BESSI0 =
+ & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
+ & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
+ & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
+ & +Y*0.392377D-2))))))))
+ ENDIF
+
+ END
+
+*$ CREATE PHO_BESSI1.FOR
+*COPY PHO_BESSI1
+CDECK ID>, PHO_BESSI1
+ DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
+C**********************************************************************
+C
+C Bessel Function I1
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ BESLI1 =
+ & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
+ & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
+ ELSE
+ Y = 3.75D0/AX
+ BESLI1 =
+ & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
+ & -Y*0.420059D-2))
+ BESLI1 =
+ & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
+ & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
+ BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
+ ENDIF
+ IF (X .LT. 0.D0) BESLI1 = -BESLI1
+
+ PHO_BESSI1 = BESLI1
+
+ END
+
+*$ CREATE PHO_BESSK0.FOR
+*COPY PHO_BESSK0
+CDECK ID>, PHO_BESSK0
+ DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
+C**********************************************************************
+C
+C Modified Bessel Function K0
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (X .LT. 2.D0) THEN
+ Y = X**2/4.D0
+ PHO_BESSK0 =
+ & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
+ & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
+ & +Y*(0.10750D-3+Y*0.740D-5))))))
+ ELSE
+ Y = 2.D0/X
+ PHO_BESSK0 =
+ & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
+ & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
+ & +Y*(-0.251540D-2+Y*0.53208D-3))))))
+ ENDIF
+
+ END
+
+*$ CREATE PHO_BESSK1.FOR
+*COPY PHO_BESSK1
+CDECK ID>, PHO_BESSK1
+ DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
+C**********************************************************************
+C
+C Modified Bessel Function K1
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (X .LT. 2.D0) THEN
+ Y = X**2/4.D0
+ PHO_BESSK1 =
+ & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
+ & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
+ & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
+ ELSE
+ Y=2.D0/X
+ PHO_BESSK1 =
+ & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
+ & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
+ & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
+ ENDIF
+
+ END
+
+*$ CREATE PHO_GAUSET.FOR
+*COPY PHO_GAUSET
+CDECK ID>, PHO_GAUSET
+ SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
+C********************************************************************
+C
+C N-point gauss zeros and weights for the interval (AX,BX) are
+C stored in arrays Z and W respectively.
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /POGDAT/A(273),X(273),KTAB(96)
+ DIMENSION Z(NX),W(NX)
+
+ ALPHA=0.5*(BX+AX)
+ BETA=0.5*(BX-AX)
+ N=NX
+
+C the N=1 case:
+ IF(N.NE.1) GO TO 1
+ Z(1)=ALPHA
+ W(1)=BX-AX
+ RETURN
+
+C the Gauss cases:
+ 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
+ IF(N.EQ.20) GO TO 2
+ IF(N.EQ.24) GO TO 2
+ IF(N.EQ.32) GO TO 2
+ IF(N.EQ.40) GO TO 2
+ IF(N.EQ.48) GO TO 2
+ IF(N.EQ.64) GO TO 2
+ IF(N.EQ.80) GO TO 2
+ IF(N.EQ.96) GO TO 2
+
+C the extended Gauss cases:
+ IF((N/96)*96.EQ.N) GO TO 3
+
+C jump to center of intervall intrgration:
+ GO TO 100
+
+C get Gauss point array
+
+ 2 CALL PHO_GAUDAT
+C extract real points
+ K=KTAB(N)
+ M=N/2
+ DO 21 J=1,M
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+C store them backward
+ Z(J)=ALPHA-DELTA
+ W(J)=WTEMP
+C store them forward
+ JP=N+1-J
+ Z(JP)=ALPHA+DELTA
+ W(JP)=WTEMP
+ 21 CONTINUE
+C store central point (odd N)
+ IF((N-M-M).EQ.0) RETURN
+ Z(M+1)=ALPHA
+ JMID=K+M
+ W(M+1)=BETA*A(JMID)
+ RETURN
+
+C get ND96 times chained 96 Gauss point array
+
+ 3 CALL PHO_GAUDAT
+C print out message
+C -extract real points
+ K=KTAB(96)
+ ND96=N/96
+ DO 31 J=1,48
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+ WTeMP=WTEMP/ND96
+ DeLTA=DELTA/ND96
+ DO 32 JD96=0,ND96-1
+ ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
+C store them backward
+ Z(J+JD96*96)=ZCNTR-DELTA
+ W(J+JD96*96)=WTEMP
+C store them forward
+ JP=96+1-J
+ Z(JP+JD96*96)=ZCNTR+DELTA
+ W(JP+JD96*96)=WTEMP
+ 32 CONTINUE
+ 31 CONTINUE
+ RETURN
+
+C the center of intervall cases:
+ 100 CONTINUE
+C put in constant weight and equally spaced central points
+ N=IABS(N)
+ DO 111 IN=1,N
+ WIN=(BX-AX)/FLOAT(N)
+ Z(IN)=AX + (FLOAT(IN)-.5)*WIN
+ 111 W(IN)=WIN
+
+ END
+
+*$ CREATE PHO_GAUDAT.FOR
+*COPY PHO_GAUDAT
+CDECK ID>, PHO_GAUDAT
+ SUBROUTINE PHO_GAUDAT
+C*********************************************************************
+C
+C store big arrays needed for Gauss integral, CERNLIB D106BD
+C (arrays A,X,ITAB copied on B,Y,LTAB)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+
+ SAVE
+ COMMON /POGDAT/ B(273),Y(273),LTAB(96)
+ DIMENSION A(273),X(273),KTAB(96)
+
+C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
+ DATA KTAB(2)/1/
+ DATA KTAB(3)/2/
+ DATA KTAB(4)/4/
+ DATA KTAB(5)/6/
+ DATA KTAB(6)/9/
+ DATA KTAB(7)/12/
+ DATA KTAB(8)/16/
+ DATA KTAB(9)/20/
+ DATA KTAB(10)/25/
+ DATA KTAB(11)/30/
+ DATA KTAB(12)/36/
+ DATA KTAB(13)/42/
+ DATA KTAB(14)/49/
+ DATA KTAB(15)/56/
+ DATA KTAB(16)/64/
+ DATA KTAB(20)/72/
+ DATA KTAB(24)/82/
+ DATA KTAB(28)/82/
+ DATA KTAB(32)/94/
+ DATA KTAB(36)/94/
+ DATA KTAB(40)/110/
+ DATA KTAB(44)/110/
+ DATA KTAB(48)/130/
+ DATA KTAB(52)/130/
+ DATA KTAB(56)/130/
+ DATA KTAB(60)/130/
+ DATA KTAB(64)/154/
+ DATA KTAB(68)/154/
+ DATA KTAB(72)/154/
+ DATA KTAB(76)/154/
+ DATA KTAB(80)/186/
+ DATA KTAB(84)/186/
+ DATA KTAB(88)/186/
+ DATA KTAB(92)/186/
+ DATA KTAB(96)/226/
+C
+C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
+C
+C-----N=2
+ DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
+C-----N=3
+ DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
+ DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
+C-----N=4
+ DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
+ DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
+C-----N=5
+ DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
+ DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
+ DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
+C-----N=6
+ DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
+ DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
+ DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
+C-----N=7
+ DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
+ DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
+ DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
+ DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
+C-----N=8
+ DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
+ DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
+ DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
+ DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
+C-----N=9
+ DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
+ DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
+ DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
+ DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
+ DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
+C-----N=10
+ DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
+ DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
+ DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
+ DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
+ DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
+C-----N=11
+ DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
+ DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
+ DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
+ DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
+ DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
+ DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
+C-----N=12
+ DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
+ DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
+ DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
+ DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
+ DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
+ DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
+C-----N=13
+ DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
+ DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
+ DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
+ DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
+ DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
+ DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
+ DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
+C-----N=14
+ DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
+ DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
+ DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
+ DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
+ DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
+ DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
+ DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
+C-----N=15
+ DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
+ DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
+ DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
+ DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
+ DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
+ DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
+ DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
+ DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
+C-----N=16
+ DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
+ DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
+ DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
+ DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
+ DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
+ DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
+ DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
+ DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
+C-----N=20
+ DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
+ DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
+ DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
+ DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
+ DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
+ DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
+ DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
+ DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
+ DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
+ DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
+C-----N=24
+ DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
+ DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
+ DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
+ DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
+ DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
+ DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
+ DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
+ DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
+ DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
+ DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
+ DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
+ DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
+C-----N=32
+ DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
+ DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
+ DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
+ DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
+ DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
+ DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
+ DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
+ DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
+ DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
+ DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
+ DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
+ DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
+ DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
+ DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
+ DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
+ DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
+C-----N=40
+ DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
+ DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
+ DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
+ DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
+ DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
+ DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
+ DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
+ DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
+ DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
+ DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
+ DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
+ DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
+ DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
+ DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
+ DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
+ DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
+ DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
+ DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
+ DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
+ DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
+C-----N=48
+ DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
+ DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
+ DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
+ DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
+ DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
+ DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
+ DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
+ DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
+ DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
+ DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
+ DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
+ DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
+ DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
+ DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
+ DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
+ DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
+ DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
+ DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
+ DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
+ DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
+ DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
+ DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
+ DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
+ DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
+C-----N=64
+ DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
+ DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
+ DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
+ DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
+ DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
+ DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
+ DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
+ DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
+ DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
+ DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
+ DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
+ DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
+ DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
+ DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
+ DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
+ DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
+ DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
+ DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
+ DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
+ DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
+ DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
+ DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
+ DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
+ DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
+ DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
+ DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
+ DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
+ DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
+ DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
+ DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
+ DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
+ DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
+C-----N=80
+ DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
+ DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
+ DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
+ DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
+ DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
+ DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
+ DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
+ DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
+ DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
+ DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
+ DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
+ DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
+ DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
+ DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
+ DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
+ DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
+ DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
+ DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
+ DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
+ DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
+ DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
+ DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
+ DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
+ DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
+ DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
+ DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
+ DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
+ DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
+ DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
+ DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
+ DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
+ DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
+ DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
+ DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
+ DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
+ DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
+ DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
+ DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
+ DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
+ DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
+C-----N=96
+ DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
+ DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
+ DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
+ DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
+ DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
+ DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
+ DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
+ DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
+ DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
+ DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
+ DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
+ DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
+ DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
+ DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
+ DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
+ DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
+ DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
+ DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
+ DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
+ DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
+ DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
+ DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
+ DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
+ DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
+ DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
+ DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
+ DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
+ DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
+ DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
+ DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
+ DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
+ DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
+ DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
+ DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
+ DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
+ DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
+ DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
+ DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
+ DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
+ DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
+ DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
+ DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
+ DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
+ DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
+ DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
+ DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
+ DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
+ DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
+ DATA IBD/0/
+ IF(IBD.NE.0) RETURN
+ IBD=1
+ DO 10 I=1,273
+ B(I) = A(I)
+ Y(I) = X(I)
+ 10 CONTINUE
+ DO 20 I=1,96
+ LTAB(I) = KTAB(I)
+ 20 CONTINUE
+ END
+
+*$ CREATE PHO_DZEROX.FOR
+*COPY PHO_DZEROX
+CDECK ID>, PHO_DZEROX
+ DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
+C**********************************************************************
+C
+C Based on
+C
+C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
+C Guaranteed Convergence for Finding a Zero of a Function,
+C ACM Trans. Math. Software 1 (1975) 330-345.
+C
+C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
+C
+C CERNLIB C200
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ CHARACTER NAME*(*)
+ PARAMETER (NAME = 'PHO_DZEROX')
+ LOGICAL LMT
+ DIMENSION IM1(2),IM2(2),LMT(2)
+ EXTERNAL F
+
+ PARAMETER (Z1 = 1, HALF = Z1/2)
+
+ DATA IM1 /2,3/, IM2 /-1,3/
+
+ IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
+ C=-2D+10
+ WRITE(LO,100) NAME,MODE
+ GO TO 99
+ ENDIF
+ FA=F(B0)
+ FB=F(A0)
+ IF(FA*FB .GT. 0) THEN
+ C=-3D+10
+ WRITE(LO,101) NAME
+ GO TO 99
+ ENDIF
+ ATL=ABS(EPS)
+ B=A0
+ A=B0
+ LMT(2)=.TRUE.
+ MF=2
+ 1 C=A
+ FC=FA
+ 2 IE=0
+ 3 IF(ABS(FC) .LT. ABS(FB)) THEN
+ IF(C .NE. A) THEN
+ D=A
+ FD=FA
+ END IF
+ A=B
+ B=C
+ C=A
+ FA=FB
+ FB=FC
+ FC=FA
+ END IF
+ TOL=ATL*(1+ABS(C))
+ H=HALF*(C+B)
+ HB=H-B
+ IF(ABS(HB) .GT. TOL) THEN
+ IF(IE .GT. IM1(MODE)) THEN
+ W=HB
+ ELSE
+ TOL=TOL*SIGN(Z1,HB)
+ P=(B-A)*FB
+ LMT(1)=IE .LE. 1
+ IF(LMT(MODE)) THEN
+ Q=FA-FB
+ LMT(2)=.FALSE.
+ ELSE
+ FDB=(FD-FB)/(D-B)
+ FDA=(FD-FA)/(D-A)
+ P=FDA*P
+ Q=FDB*FA-FDA*FB
+ END IF
+ IF(P .LT. 0) THEN
+ P=-P
+ Q=-Q
+ END IF
+ IF(IE .EQ. IM2(MODE)) P=P+P
+ IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
+ W=TOL
+ ELSEIF(P .LT. HB*Q) THEN
+ W=P/Q
+ ELSE
+ W=HB
+ END IF
+ END IF
+ D=A
+ A=B
+ FD=FA
+ FA=FB
+ B=B+W
+ MF=MF+1
+ IF(MF .GT. MAXF) THEN
+ WRITE(LO,102) NAME
+ GO TO 99
+ ENDIF
+ FB=F(B)
+ IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
+ IF(W .EQ. HB) GO TO 2
+ IE=IE+1
+ GO TO 3
+ END IF
+ 99 CONTINUE
+ PHO_DZEROX=C
+ RETURN
+ 100 FORMAT(1X,A,': mode = ',I3,' illegal')
+ 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
+ 102 FORMAT(1X,A,': too many function calls')
+
+ END
+
+*$ CREATE PHO_EXPINT.FOR
+*COPY PHO_EXPINT
+CDECK ID>, PHO_EXPINT
+ DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
+C***********************************************************************
+C
+C function to calculate E_i(x) = -E_1(-x)
+C
+C based on CERNLIB C337 (changed by R.Engel 10/1993)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
+ DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
+ DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
+
+ DATA X0 /0.37250 74107 8137D0/
+ DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
+ DATA P1
+ 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
+ 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
+ 3 -4.34981 43832 952D+2/
+ DATA Q1
+ 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
+ 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
+ 3 +7.53585 64359 843D+2/
+ DATA P2
+ 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
+ 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
+ 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
+ 4 +4.65627 10797 510D-7/
+ DATA Q2
+ 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
+ 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
+ 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
+ 4 +1.00000 00000 000D+0/
+ DATA P3
+ 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
+ 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
+ 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
+ DATA Q3
+ 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
+ 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
+ 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
+ DATA P4
+ 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
+ 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
+ 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
+ 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
+ DATA Q4
+ 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
+ 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
+ 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
+ 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
+ DATA A1
+ 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
+ 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
+ 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
+ 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
+ DATA B1
+ 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
+ 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
+ 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
+ 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
+ DATA A2
+ 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
+ 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
+ 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
+ 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
+ DATA B2
+ 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
+ 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
+ 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
+ 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
+ DATA A3
+ 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
+ 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
+ 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
+ DATA B3
+ 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
+ 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
+ 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
+C
+C conversion to E_i function
+ X = -RXM
+C
+ IF(X .LE. XL(1)) THEN
+ AP=A3(1)-X
+ DO 1 I = 2,5
+ 1 AP=A3(I)-X+B3(I)/AP
+ Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
+ ELSEIF(X .LE. XL(2)) THEN
+ AP=A2(1)-X
+ DO 2 I = 2,7
+ 2 AP=A2(I)-X+B2(I)/AP
+ Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
+ ELSEIF(X .LE. XL(3)) THEN
+ AP=A1(1)-X
+ DO 3 I = 2,7
+ 3 AP=A1(I)-X+B1(I)/AP
+ Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
+ ELSEIF(X .LT. XL(4)) THEN
+ V=-2.D0*(X/3.D0+1.D0)
+ BP=0.D0
+ DP=P4(1)
+ DO 4 I = 2,8
+ AP=BP
+ BP=DP
+ 4 DP=P4(I)-AP+V*BP
+ BQ=0.D0
+ DQ=Q4(1)
+ DO 14 I = 2,8
+ AQ=BQ
+ BQ=DQ
+ 14 DQ=Q4(I)-AQ+V*BQ
+ Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
+ ELSEIF(X .EQ. XL(4)) THEN
+* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
+* IF(MFLAG) THEN
+* IF(LGFILE .EQ. 0) THEN
+* WRITE(LO,100) ENAME
+* ELSE
+* WRITE(LGFILE,100) ENAME
+* ENDIF
+* ENDIF
+* IF(.NOT.RFLAG) CALL ABEND
+ PHO_EXPINT=0.D0
+ RETURN
+ ELSEIF(X .LT. XL(5)) THEN
+ AP=P1(1)
+ AQ=Q1(1)
+ DO 5 I = 2,5
+ AP=P1(I)+X*AP
+ 5 AQ=Q1(I)+X*AQ
+ Y=-LOG(X)+AP/AQ
+ ELSEIF(X .LE. XL(6)) THEN
+ Y=1.D0/X
+ AP=P2(1)
+ AQ=Q2(1)
+ DO 6 I = 2,7
+ AP=P2(I)+Y*AP
+ 6 AQ=Q2(I)+Y*AQ
+ Y=EXP(-X)*AP/AQ
+ ELSE
+ Y=1.D0/X
+ AP=P3(1)
+ AQ=Q3(1)
+ DO 7 I = 2,6
+ AP=P3(I)+Y*AP
+ 7 AQ=Q3(I)+Y*AQ
+ Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
+ ENDIF
+C sign conversion to E_i
+ PHO_EXPINT=-Y
+
+ END
+
+*$ CREATE PHO_RNDBET.FOR
+*COPY PHO_RNDBET
+CDECK ID>, PHO_RNDBET
+ DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
+C********************************************************************
+C
+C RANDOM NUMBER GENERATION FROM BETA
+C DISTRIBUTION IN REGION 0 < X < 1.
+C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
+C *GAMM(ETA))
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ Y = PHO_RNDGAM(1.D0,GAM)
+ Z = PHO_RNDGAM(1.D0,ETA)
+
+ PHO_RNDBET = Y/(Y+Z)
+
+ END
+
+*$ CREATE PHO_RNDGAM.FOR
+*COPY PHO_RNDGAM
+CDECK ID>, PHO_RNDGAM
+ DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
+C********************************************************************
+C
+C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
+C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ NCOU=0
+ N = ETA
+ F = ETA - N
+ IF(F.EQ.0.D0) GOTO 20
+ 10 R = DT_RNDM(ETA)
+ NCOU=NCOU+1
+ IF (NCOU.GE.11) GOTO 20
+ IF(R.LT.F/(F+2.71828D0)) GOTO 30
+ YYY=LOG(DT_RNDM(F)+1.0D-9)/F
+ IF(ABS(YYY).GT.50.D0) GOTO 20
+ Y = EXP(YYY)
+ IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
+ GOTO 40
+ 20 Y = 0.D0
+ GOTO 50
+ 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
+ IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
+ 40 IF(N.EQ.0) GOTO 70
+ 50 Z = 1.D0
+ DO 60 I = 1,N
+ 60 Z = Z*DT_RNDM(Y)
+ Y = Y-LOG(Z+1.0D-9)
+ 70 PHO_RNDGAM = Y/ALAM
+ RETURN
+ END
+
+*$ CREATE PHO_SFECFE.FOR
+*COPY PHO_SFECFE
+CDECK ID>, PHO_SFECFE
+ SUBROUTINE PHO_SFECFE(SFE,CFE)
+C**********************************************************************
+C
+C fast random SIN(X) COS(X) selection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ 1 CONTINUE
+ X=DT_RNDM(XX)
+ Y=DT_RNDM(YY)
+ XX=X*X
+ YY=Y*Y
+ XY=XX+YY
+ IF(XY.GT.1.D0) GOTO 1
+ CFE=(XX-YY)/XY
+ SFE=2.D0*X*Y/XY
+ IF(DT_RNDM(XY).LT.0.5D0) THEN
+ SFE=-SFE
+ ENDIF
+ END
+
+*$ CREATE PHO_SWAPD.FOR
+*COPY PHO_SWAPD
+CDECK ID>, PHO_SWAPD
+ SUBROUTINE PHO_SWAPD(D1,D2)
+C********************************************************************
+C
+C exchange of argument values (double precision)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ D = D1
+ D1 = D2
+ D2 = D
+ END
+
+*$ CREATE PHO_SWAPI.FOR
+*COPY PHO_SWAPI
+CDECK ID>, PHO_SWAPI
+ SUBROUTINE PHO_SWAPI(I1,I2)
+C********************************************************************
+C
+C exchange of argument values (integer)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ K = I1
+ I1 = I2
+ I2 = K
+ END
+
+*$ CREATE PHO_HADCSL.FOR
+*COPY PHO_HADCSL
+CDECK ID>, PHO_HADCSL
+ SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
+ & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
+C***********************************************************************
+C
+C low-energy cross section parametrizations
+C
+C input: ID1,ID2 PDG IDs of particles (meson first)
+C ECM c.m. energy (GeV)
+C PLAB lab. momentum (second particle at rest)
+C IMODE 1 ECM given, PLAB ignored
+C 2 PLAB given, ECM ignored
+C
+C output: SIGTOT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
+C SLOPE forward elastic slope (GeV**-2)
+C RHO real/imaginary part of elastic amplitude
+C
+C comments:
+C
+C - low-energy data interpolation uses PDG fits from 1992 issue
+C - high-energy extrapolation by Donnachie-Landshoff like fit made
+C by PDG 1996
+C - analytic extension of amplitude to calculate rho
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER ID1,ID2,IMODE
+ DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ INTEGER K
+ DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
+ & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
+
+ DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
+
+ DATA TPDG92 /
+ & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
+ & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
+ & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
+ & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
+ & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
+ & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
+ & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
+ & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
+ & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
+ & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
+ & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
+ & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
+
+ DATA TPDG96 /
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,-21.05D0,0.46D0,0.9D0,
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,21.05D0,0.46D0,0.9D0,
+ & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
+ & 31.85D0,-4.05D0,0.45D0,0.9D0,
+ & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
+ & 31.85D0,4.05D0,0.45D0,0.9D0,
+ & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
+ & 17.35D0,-9.05D0,0.50D0,0.9D0,
+ & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
+ & 17.35D0,9.05D0,0.50D0,0.9D0 /
+
+ DATA BURQ83 /
+ & 11.13D0, -6.21D0, 0.30D0,
+ & 11.13D0, 7.23D0, 0.30D0,
+ & 9.11D0, -0.73D0, 0.28D0,
+ & 9.11D0, 0.65D0, 0.28D0,
+ & 8.55D0, -5.98D0, 0.28D0,
+ & 8.55D0, 1.60D0, 0.28D0 /
+
+ DATA XMA /
+ & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
+
+C find index
+ IF(ID2.NE.2212) THEN
+ GOTO 100
+ ELSE IF(ID1.EQ.2212) THEN
+ K = 1
+ ELSE IF(ID1.EQ.-2212) THEN
+ K = 2
+ ELSE IF(ID1.EQ.211) THEN
+ K = 3
+ ELSE IF(ID1.EQ.-211) THEN
+ K = 4
+ ELSE IF(ID1.EQ.321) THEN
+ K = 5
+ ELSE IF(ID1.EQ.-321) THEN
+ K = 6
+ ELSE
+ GOTO 100
+ ENDIF
+
+C calculate lab momentum
+ IF(IMODE.EQ.1) THEN
+ SS = ECM**2
+ E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
+ PL = SQRT(E1*E1-XMA(K)**2)
+ ELSE IF(IMODE.EQ.2) THEN
+ PL = PLAB
+ SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
+ ECM = SQRT(SS)
+ ELSE
+ WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
+ RETURN
+ ENDIF
+ PLL = LOG(PL)
+
+C check against lower limit
+ IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
+
+ XP = TPDG96(2,K)*SS**TPDG96(3,K)
+ YP = TPDG96(6,K)/SS**TPDG96(8,K)
+ YM = TPDG96(7,K)/SS**TPDG96(8,K)
+
+ PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
+ PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
+ RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
+ SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
+
+C select energy range and interpolation method
+ IF(PL.LT.TPDG96(1,K)) THEN
+ SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
+ SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ SIGTO2 = YP+YM+XP
+ SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
+ X1 = 1.D0 - X2
+ SIGTOT = SIGTO2*X2 + SIGTO1*X1
+ SIGEL = SIGEL2*X2 + SIGEL1*X1
+ ELSE
+ SIGTOT = YP+YM+XP
+ SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ ENDIF
+
+C no parametrization of diffraction implemented
+ SIGDIF(1) = -1.D0
+ SIGDIF(2) = -1.D0
+ SIGDIF(3) = -1.D0
+
+ RETURN
+
+ 100 CONTINUE
+ WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
+ & 'invalid particle combination: ',ID1,ID2
+ RETURN
+
+ 200 CONTINUE
+ WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
+ & 'energy too small (Ecm,Plab): ',ECM,PLAB
+
+ END
+
+*$ CREATE PHO_CSDIFF.FOR
+*COPY PHO_CSDIFF
+CDECK ID>, PHO_CSDIFF
+ SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
+ & sig_sd1,sig_sd2,sig_dd)
+C***********************************************************************
+C
+C cross section for diffraction dissociation according to
+C Goulianos' parametrization (Ref: PL B358 (1995) 379)
+C
+C in addition rescaling for different particles is applied using
+C internal rescaling tables (not implemented yet)
+C
+C input: Id1/2 PDG ID's of incoming particles
+C SS squared c.m. energy (GeV**2)
+C Xi_min min. diff mass (squared) = Xi_min*SS
+C Xi_max max. diff mass (squared) = Xi_max*SS
+C
+C output: sig_sd1 cross section for diss. of particle 1 (mb)
+C sig_sd2 cross section for diss. of particle 2 (mb)
+C sig_dd cross section for diss. of both particles
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER Id1,Id2
+ DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
+ DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
+ & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
+ & xms_1,xms_2,CSdiff
+
+ INTEGER Ngau1,Ngau2,i1,i2
+
+C model parameters
+
+ DATA delta / 0.104d0 /
+ DATA alphap / 0.25d0 /
+ DATA beta0 / 6.56d0 /
+ DATA gpom0 / 1.21d0 /
+ DATA xm_p / 0.938d0 /
+ DATA x_rad2 / 0.71d0 /
+
+C integration precision
+
+ DATA Ngau1 / 96 /
+ DATA Ngau2 / 96 /
+
+ sig_sd1 = 0.d0
+ sig_sd2 = 0.d0
+ sig_dd = 0.d0
+
+ IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
+
+ xm4_p2 = 4.D0*xm_p**2
+ fac = beta0**2/(16.D0*PI)
+
+ t1 = -5.D0
+ t2 = 0.D0
+ tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C flux renormalization and cross section
+
+ Xnorm = 0.d0
+
+ xil = log(1.5d0/SS)
+ xiu = log(0.1d0)
+
+ IF(xiu.LE.xil) goto 1000
+
+ CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
+ CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ w_xi = Xwgh1(i1)
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ Xnorm = Xnorm
+ & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ Xnorm = Xnorm*fac
+
+ 1000 continue
+
+ XIL = LOG(Xi_min)
+ XIU = LOG(Xi_max)
+
+ T1 = -5.D0
+ T2 = 0.D0
+
+ TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C single diffraction diss. cross section
+
+ CSdiff = 0.d0
+
+ IF(XIU.LE.XIL) goto 2000
+
+ CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
+ CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ CSdiff = CSdiff
+ & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
+
+* WRITE(LO,'(1x,1p,4e14.3)')
+* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
+
+ sig_sd1 = CSdiff
+ sig_sd2 = CSdiff
+
+ 2000 continue
+
+C double diffraction dissociation cross section
+
+ CSdiff = 0.d0
+
+ xil = log(1.5d0/SS)
+ xiu = log(Xi_max/1.5d0)
+
+ IF(xiu.LE.xil) goto 3000
+
+ fac = (beta0*gpom0*SS**delta
+ & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
+ & /(2.d0*alphap)
+
+ CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ xms_1 = xi*SS
+
+ xiu = log(Xi_max/(xi*SS))
+
+ if(xil.lt.xiu) then
+
+ CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
+
+ do i2=1,Ngau2
+
+ xms_2 = exp(xpos2(i2))*SS
+ CSdiff = CSdiff
+ & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
+ & *xwgh1(i1)*xwgh2(i2)
+
+ enddo
+
+ endif
+
+ enddo
+
+ sig_dd = CSdiff*fac*GEV2MB
+
+ 3000 continue
+
+ ELSE
+
+ WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
+ & 'invalid particle combination (Id1/2)',Id1,Id2
+
+ ENDIF
+
+ END
+
+*$ CREATE PHO_ALLM97.FOR
+*COPY PHO_ALLM97
+CDECK ID>, PHO_ALLM97
+ DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
+C**********************************************************************
+C
+C ALLM97 parametrization for gamma*-p cross section
+C (for F2 see comments, code adapted from V. Shekelyan, H1)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION Q2,W
+ DOUBLE PRECISION M02,M12,LAM2,M22
+ DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
+ DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
+ DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
+ & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
+ DATA ALFA,XMP2 /112.2D0 , .8802D0 /
+
+ W2=W*W
+ PHO_ALLM97 = 0.D0
+
+C pomeron
+ S11 = 0.28067D0
+ S12 = 0.22291D0
+ S13 = 2.1979D0
+ A11 = -0.0808D0
+ A12 = -0.44812D0
+ A13 = 1.1709D0
+ B11 = 0.60243D0
+ B12 = 1.3754D0
+ B13 = 1.8439D0
+ M12 = 49.457D0
+
+C reggeon
+ S21 = 0.80107D0
+ S22 = 0.97307D0
+ S23 = 3.4942D0
+ A21 = 0.58400D0
+ A22 = 0.37888D0
+ A23 = 2.6063D0
+ B21 = 0.10711D0
+ B22 = 1.9386D0
+ B23 = 0.49338D0
+ M22 = 0.15052D0
+C
+ M02 = 0.31985D0
+ LAM2 = 0.065270D0
+ Q02 = 0.46017D0 +LAM2
+
+C
+ S=0.
+ T=LOG((Q2+Q02)/LAM2)
+ T0=LOG(Q02/LAM2)
+ IF(Q2.GT.0.D0) S=LOG(T/T0)
+ Z=1.D0
+
+ IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
+
+ IF(S.LT.0.01D0) THEN
+
+C pomeron part
+
+ XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
+
+ AP=A11
+ BP=B11**2
+
+ SP=S11
+ F2P=SP*XP**AP*Z**BP
+
+C reggeon part
+
+ XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
+
+ AR=A21
+ BR=B21**2
+
+ SR=S21
+ F2R=SR*XR**AR*Z**BR
+
+ ELSE
+
+C pomeron part
+
+ XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
+
+ AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
+
+ BP=B11**2+B12**2*S**B13
+
+ SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
+
+ F2P=SP*XP**AP*Z**BP
+
+C reggeon part
+
+ XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
+
+ AR=A21+A22*S**A23
+ BR=B21**2+B22**2*S**B23
+
+ SR=S21+S22*S**S23
+ F2R=SR*XR**AR*Z**BR
+
+ ENDIF
+
+* F2 = (F2P+F2R)*Q2/(Q2+M02)
+
+ CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
+ PHO_ALLM97 = CIN*(F2P+F2R)
+
+ END
+
+*$ CREATE PHO_DOR98LO.FOR
+*COPY PHO_DOR98LO
+CDECK ID>, PHO_DOR98LO
+ SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
+C***********************************************************************
+C
+C GRV98 parton densities, leading order set
+C
+C For a detailed explanation see
+C M. Glueck, E. Reya, A. Vogt :
+C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
+C (To appear in Eur. Phys. J. C)
+C
+C interpolation routine based on the original GRV98PA routine,
+C adapted to define interpolation table as DATA statements
+C
+C (R.Engel, 09/98)
+C
+C
+C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
+C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
+C
+C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
+C DS = d(bar), SS = s = s(bar), GL = gluon.
+C Always x times the distribution is returned.
+C
+C******************************************************i****************
+ IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
+ DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
+ 1 XSF(NX,NQ), XGF(NX,NQ),
+ 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
+
+ DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
+ & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
+
+ EQUIVALENCE (XUVF(1,1),XUVF_L(1))
+ EQUIVALENCE (XDVF(1,1),XDVF_L(1))
+ EQUIVALENCE (XDEF(1,1),XDEF_L(1))
+ EQUIVALENCE (XUDF(1,1),XUDF_L(1))
+ EQUIVALENCE (XSF(1,1),XSF_L(1))
+ EQUIVALENCE (XGF(1,1),XGF_L(1))
+
+ DATA (ARRF(K),K= 1, 95) /
+ & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
+ & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
+ & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
+ & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
+ & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
+ & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
+ & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
+ & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
+ & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
+ & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
+ & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
+ & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
+ & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
+ & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
+ & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
+ & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
+ & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
+ & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
+ & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
+ DATA (XUVF_L(K),K= 1, 114) /
+ &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
+ &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
+ &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
+ &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
+ &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
+ &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
+ &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
+ &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
+ &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
+ &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
+ &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
+ &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
+ &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
+ &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
+ &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
+ &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
+ &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
+ &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
+ &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
+ DATA (XUVF_L(K),K= 115, 228) /
+ &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
+ &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
+ &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
+ &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
+ &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
+ &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
+ &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
+ &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
+ &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
+ &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
+ &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
+ &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
+ &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
+ &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
+ &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
+ &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
+ &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
+ &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
+ &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
+ DATA (XUVF_L(K),K= 229, 342) /
+ &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
+ &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
+ &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
+ &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
+ &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
+ &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
+ &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
+ &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
+ &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
+ &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
+ &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
+ &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
+ &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
+ &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
+ &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
+ &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
+ &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
+ &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
+ &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
+ DATA (XUVF_L(K),K= 343, 456) /
+ &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
+ &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
+ &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
+ &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
+ &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
+ &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
+ &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
+ &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
+ &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
+ &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
+ &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
+ &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
+ &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
+ &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
+ &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
+ &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
+ &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
+ &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
+ &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
+ DATA (XUVF_L(K),K= 457, 570) /
+ &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
+ &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
+ &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
+ &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
+ &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
+ &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
+ &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
+ &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
+ &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
+ &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
+ &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
+ &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
+ &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
+ &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
+ &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
+ &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
+ &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
+ &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
+ &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
+ DATA (XUVF_L(K),K= 571, 684) /
+ &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
+ &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
+ &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
+ &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
+ &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
+ &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
+ &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
+ &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
+ &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
+ &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
+ &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
+ &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
+ &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
+ &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
+ &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
+ &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
+ &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
+ &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
+ &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
+ DATA (XUVF_L(K),K= 685, 798) /
+ &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
+ &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
+ &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
+ &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
+ &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
+ &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
+ &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
+ &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
+ &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
+ &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
+ &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
+ &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
+ &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
+ &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
+ &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
+ &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
+ &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
+ &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
+ &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
+ DATA (XUVF_L(K),K= 799, 912) /
+ &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
+ &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
+ &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
+ &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
+ &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
+ &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
+ &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
+ &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
+ &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
+ &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
+ &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
+ &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
+ &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
+ &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
+ &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
+ &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
+ &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
+ &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
+ &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
+ DATA (XUVF_L(K),K= 913, 1026) /
+ &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
+ &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
+ &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
+ &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
+ &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
+ &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
+ &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
+ &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
+ &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
+ &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
+ &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
+ &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
+ &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
+ &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
+ &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
+ &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
+ &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
+ &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
+ &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
+ DATA (XUVF_L(K),K= 1027, 1140) /
+ &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
+ &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
+ &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
+ &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
+ &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
+ &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
+ &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
+ &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
+ &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
+ &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
+ &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
+ &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
+ &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
+ &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
+ &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
+ &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
+ &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
+ &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
+ &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
+ DATA (XUVF_L(K),K= 1141, 1254) /
+ &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
+ &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
+ &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
+ &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
+ &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
+ &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
+ &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
+ &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
+ &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
+ &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
+ &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
+ &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
+ &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
+ &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
+ &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
+ &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
+ &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
+ &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
+ &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
+ DATA (XUVF_L(K),K= 1255, 1368) /
+ &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
+ &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
+ &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
+ &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
+ &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
+ &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
+ &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
+ &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
+ &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
+ &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
+ &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
+ &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
+ &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
+ &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
+ &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
+ &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
+ &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
+ &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
+ &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
+ DATA (XUVF_L(K),K= 1369, 1482) /
+ &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
+ &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
+ &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
+ &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
+ &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
+ &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
+ &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
+ &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
+ &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
+ &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
+ &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
+ &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
+ &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
+ &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
+ &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
+ &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
+ &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
+ &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
+ &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
+ DATA (XUVF_L(K),K= 1483, 1596) /
+ &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
+ &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
+ &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
+ &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
+ &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
+ &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
+ &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
+ &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
+ &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
+ &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
+ &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
+ &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
+ &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
+ &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
+ &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
+ &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
+ &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
+ &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
+ &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
+ DATA (XUVF_L(K),K= 1597, 1710) /
+ &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
+ &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
+ &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
+ &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
+ &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
+ &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
+ &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
+ &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
+ &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
+ &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
+ &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
+ &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
+ &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
+ &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
+ &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
+ &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
+ &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
+ &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
+ &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
+ DATA (XUVF_L(K),K= 1711, 1824) /
+ &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
+ &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
+ &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
+ &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
+ &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
+ &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
+ &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
+ &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
+ &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
+ &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
+ &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
+ &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
+ &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
+ &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
+ &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
+ &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
+ &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
+ &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
+ &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
+ DATA (XUVF_L(K),K= 1825, 1836) /
+ &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
+ &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
+ DATA (XDVF_L(K),K= 1, 114) /
+ &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
+ &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
+ &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
+ &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
+ &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
+ &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
+ &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
+ &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
+ &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
+ &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
+ &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
+ &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
+ &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
+ &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
+ &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
+ &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
+ &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
+ &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
+ &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
+ DATA (XDVF_L(K),K= 115, 228) /
+ &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
+ &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
+ &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
+ &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
+ &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
+ &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
+ &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
+ &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
+ &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
+ &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
+ &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
+ &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
+ &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
+ &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
+ &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
+ &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
+ &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
+ &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
+ &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
+ DATA (XDVF_L(K),K= 229, 342) /
+ &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
+ &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
+ &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
+ &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
+ &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
+ &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
+ &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
+ &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
+ &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
+ &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
+ &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
+ &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
+ &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
+ &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
+ &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
+ &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
+ &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
+ &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
+ &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
+ DATA (XDVF_L(K),K= 343, 456) /
+ &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
+ &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
+ &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
+ &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
+ &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
+ &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
+ &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
+ &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
+ &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
+ &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
+ &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
+ &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
+ &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
+ &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
+ &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
+ &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
+ &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
+ &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
+ &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
+ DATA (XDVF_L(K),K= 457, 570) /
+ &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
+ &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
+ &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
+ &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
+ &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
+ &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
+ &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
+ &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
+ &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
+ &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
+ &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
+ &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
+ &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
+ &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
+ &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
+ &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
+ &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
+ &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
+ &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
+ DATA (XDVF_L(K),K= 571, 684) /
+ &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
+ &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
+ &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
+ &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
+ &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
+ &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
+ &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
+ &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
+ &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
+ &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
+ &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
+ &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
+ &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
+ &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
+ &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
+ &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
+ &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
+ &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
+ &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
+ DATA (XDVF_L(K),K= 685, 798) /
+ &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
+ &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
+ &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
+ &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
+ &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
+ &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
+ &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
+ &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
+ &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
+ &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
+ &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
+ &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
+ &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
+ &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
+ &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
+ &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
+ &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
+ &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
+ &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
+ DATA (XDVF_L(K),K= 799, 912) /
+ &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
+ &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
+ &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
+ &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
+ &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
+ &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
+ &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
+ &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
+ &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
+ &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
+ &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
+ &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
+ &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
+ &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
+ &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
+ &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
+ &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
+ &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
+ &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
+ DATA (XDVF_L(K),K= 913, 1026) /
+ &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
+ &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
+ &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
+ &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
+ &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
+ &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
+ &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
+ &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
+ &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
+ &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
+ &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
+ &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
+ &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
+ &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
+ &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
+ &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
+ &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
+ &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
+ &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
+ DATA (XDVF_L(K),K= 1027, 1140) /
+ &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
+ &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
+ &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
+ &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
+ &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
+ &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
+ &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
+ &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
+ &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
+ &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
+ &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
+ &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
+ &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
+ &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
+ &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
+ &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
+ &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
+ &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
+ &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
+ DATA (XDVF_L(K),K= 1141, 1254) /
+ &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
+ &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
+ &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
+ &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
+ &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
+ &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
+ &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
+ &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
+ &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
+ &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
+ &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
+ &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
+ &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
+ &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
+ &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
+ &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
+ &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
+ &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
+ &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
+ DATA (XDVF_L(K),K= 1255, 1368) /
+ &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
+ &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
+ &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
+ &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
+ &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
+ &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
+ &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
+ &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
+ &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
+ &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
+ &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
+ &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
+ &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
+ &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
+ &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
+ &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
+ &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
+ &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
+ &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
+ DATA (XDVF_L(K),K= 1369, 1482) /
+ &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
+ &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
+ &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
+ &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
+ &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
+ &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
+ &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
+ &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
+ &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
+ &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
+ &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
+ &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
+ &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
+ &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
+ &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
+ &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
+ &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
+ &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
+ &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
+ DATA (XDVF_L(K),K= 1483, 1596) /
+ &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
+ &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
+ &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
+ &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
+ &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
+ &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
+ &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
+ &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
+ &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
+ &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
+ &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
+ &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
+ &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
+ &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
+ &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
+ &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
+ &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
+ &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
+ &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
+ DATA (XDVF_L(K),K= 1597, 1710) /
+ &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
+ &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
+ &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
+ &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
+ &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
+ &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
+ &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
+ &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
+ &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
+ &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
+ &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
+ &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
+ &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
+ &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
+ &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
+ &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
+ &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
+ &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
+ &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
+ DATA (XDVF_L(K),K= 1711, 1824) /
+ &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
+ &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
+ &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
+ &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
+ &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
+ &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
+ &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
+ &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
+ &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
+ &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
+ &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
+ &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
+ &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
+ &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
+ &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
+ &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
+ &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
+ &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
+ &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
+ DATA (XDVF_L(K),K= 1825, 1836) /
+ &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
+ &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
+ DATA (XDEF_L(K),K= 1, 114) /
+ &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
+ &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
+ &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
+ &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
+ &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
+ &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
+ &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
+ &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
+ &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
+ &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
+ &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
+ &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
+ &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
+ &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
+ &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
+ &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
+ &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
+ &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
+ DATA (XDEF_L(K),K= 115, 228) /
+ &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
+ &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
+ &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
+ &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
+ &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
+ &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
+ &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
+ &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
+ &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
+ &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
+ &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
+ &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
+ &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
+ &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
+ &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
+ &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
+ &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
+ DATA (XDEF_L(K),K= 229, 342) /
+ &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
+ &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
+ &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
+ &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
+ &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
+ &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
+ &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
+ &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
+ &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
+ &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
+ &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
+ &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
+ &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
+ &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
+ &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
+ &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
+ &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
+ DATA (XDEF_L(K),K= 343, 456) /
+ &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
+ &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
+ &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
+ &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
+ &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
+ &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
+ &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
+ &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
+ &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
+ &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
+ &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
+ &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
+ &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
+ &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
+ &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
+ &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
+ &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
+ &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
+ DATA (XDEF_L(K),K= 457, 570) /
+ &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
+ &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
+ &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
+ &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
+ &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
+ &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
+ &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
+ &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
+ &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
+ &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
+ &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
+ &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
+ &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
+ &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
+ &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
+ &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
+ &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
+ DATA (XDEF_L(K),K= 571, 684) /
+ &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
+ &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
+ &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
+ &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
+ &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
+ &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
+ &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
+ &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
+ &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
+ &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
+ &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
+ &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
+ &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
+ &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
+ &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
+ &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
+ &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
+ DATA (XDEF_L(K),K= 685, 798) /
+ &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
+ &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
+ &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
+ &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
+ &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
+ &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
+ &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
+ &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
+ &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
+ &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
+ &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
+ &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
+ &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
+ &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
+ &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
+ &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
+ &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
+ &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
+ DATA (XDEF_L(K),K= 799, 912) /
+ &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
+ &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
+ &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
+ &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
+ &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
+ &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
+ &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
+ &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
+ &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
+ &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
+ &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
+ &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
+ &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
+ &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
+ &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
+ &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
+ &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
+ DATA (XDEF_L(K),K= 913, 1026) /
+ &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
+ &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
+ &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
+ &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
+ &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
+ &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
+ &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
+ &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
+ &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
+ &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
+ &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
+ &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
+ &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
+ &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
+ &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
+ &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
+ &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
+ DATA (XDEF_L(K),K= 1027, 1140) /
+ &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
+ &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
+ &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
+ &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
+ &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
+ &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
+ &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
+ &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
+ &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
+ &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
+ &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
+ &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
+ &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
+ &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
+ &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
+ &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
+ &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
+ &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
+ DATA (XDEF_L(K),K= 1141, 1254) /
+ &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
+ &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
+ &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
+ &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
+ &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
+ &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
+ &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
+ &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
+ &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
+ &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
+ &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
+ &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
+ &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
+ &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
+ &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
+ &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
+ &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
+ DATA (XDEF_L(K),K= 1255, 1368) /
+ &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
+ &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
+ &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
+ &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
+ &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
+ &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
+ &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
+ &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
+ &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
+ &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
+ &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
+ &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
+ &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
+ &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
+ &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
+ &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
+ &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
+ DATA (XDEF_L(K),K= 1369, 1482) /
+ &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
+ &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
+ &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
+ &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
+ &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
+ &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
+ &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
+ &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
+ &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
+ &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
+ &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
+ &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
+ &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
+ &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
+ &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
+ &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
+ &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
+ &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
+ DATA (XDEF_L(K),K= 1483, 1596) /
+ &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
+ &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
+ &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
+ &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
+ &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
+ &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
+ &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
+ &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
+ &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
+ &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
+ &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
+ &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
+ &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
+ &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
+ &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
+ &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
+ &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
+ DATA (XDEF_L(K),K= 1597, 1710) /
+ &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
+ &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
+ &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
+ &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
+ &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
+ &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
+ &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
+ &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
+ &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
+ &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
+ &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
+ &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
+ &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
+ &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
+ &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
+ &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
+ &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
+ DATA (XDEF_L(K),K= 1711, 1824) /
+ &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
+ &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
+ &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
+ &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
+ &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
+ &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
+ &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
+ &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
+ &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
+ &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
+ &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
+ &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
+ &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
+ &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
+ &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
+ &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
+ &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
+ &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
+ DATA (XDEF_L(K),K= 1825, 1836) /
+ &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
+ DATA (XUDF_L(K),K= 1, 114) /
+ &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
+ &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
+ &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
+ &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
+ &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
+ &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
+ &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
+ &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
+ &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
+ &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
+ &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
+ &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
+ &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
+ &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
+ &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
+ &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
+ &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
+ &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
+ &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
+ DATA (XUDF_L(K),K= 115, 228) /
+ &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
+ &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
+ &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
+ &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
+ &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
+ &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
+ &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
+ &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
+ &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
+ &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
+ &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
+ &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
+ &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
+ &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
+ &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
+ &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
+ &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
+ &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
+ &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
+ DATA (XUDF_L(K),K= 229, 342) /
+ &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
+ &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
+ &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
+ &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
+ &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
+ &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
+ &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
+ &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
+ &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
+ &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
+ &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
+ &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
+ &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
+ &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
+ &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
+ &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
+ &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
+ &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
+ &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
+ DATA (XUDF_L(K),K= 343, 456) /
+ &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
+ &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
+ &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
+ &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
+ &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
+ &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
+ &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
+ &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
+ &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
+ &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
+ &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
+ &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
+ &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
+ &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
+ &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
+ &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
+ &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
+ &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
+ &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
+ DATA (XUDF_L(K),K= 457, 570) /
+ &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
+ &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
+ &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
+ &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
+ &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
+ &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
+ &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
+ &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
+ &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
+ &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
+ &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
+ &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
+ &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
+ &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
+ &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
+ &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
+ &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
+ &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
+ &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
+ DATA (XUDF_L(K),K= 571, 684) /
+ &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
+ &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
+ &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
+ &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
+ &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
+ &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
+ &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
+ &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
+ &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
+ &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
+ &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
+ &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
+ &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
+ &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
+ &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
+ &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
+ &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
+ &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
+ &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
+ DATA (XUDF_L(K),K= 685, 798) /
+ &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
+ &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
+ &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
+ &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
+ &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
+ &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
+ &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
+ &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
+ &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
+ &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
+ &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
+ &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
+ &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
+ &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
+ &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
+ &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
+ &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
+ &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
+ &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
+ DATA (XUDF_L(K),K= 799, 912) /
+ &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
+ &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
+ &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
+ &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
+ &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
+ &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
+ &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
+ &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
+ &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
+ &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
+ &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
+ &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
+ &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
+ &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
+ &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
+ &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
+ &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
+ &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
+ &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
+ DATA (XUDF_L(K),K= 913, 1026) /
+ &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
+ &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
+ &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
+ &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
+ &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
+ &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
+ &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
+ &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
+ &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
+ &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
+ &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
+ &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
+ &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
+ &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
+ &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
+ &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
+ &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
+ &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
+ &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
+ DATA (XUDF_L(K),K= 1027, 1140) /
+ &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
+ &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
+ &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
+ &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
+ &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
+ &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
+ &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
+ &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
+ &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
+ &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
+ &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
+ &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
+ &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
+ &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
+ &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
+ &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
+ &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
+ &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
+ &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
+ DATA (XUDF_L(K),K= 1141, 1254) /
+ &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
+ &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
+ &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
+ &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
+ &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
+ &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
+ &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
+ &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
+ &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
+ &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
+ &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
+ &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
+ &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
+ &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
+ &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
+ &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
+ &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
+ &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
+ &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
+ DATA (XUDF_L(K),K= 1255, 1368) /
+ &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
+ &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
+ &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
+ &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
+ &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
+ &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
+ &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
+ &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
+ &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
+ &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
+ &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
+ &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
+ &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
+ &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
+ &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
+ &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
+ &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
+ &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
+ &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
+ DATA (XUDF_L(K),K= 1369, 1482) /
+ &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
+ &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
+ &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
+ &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
+ &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
+ &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
+ &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
+ &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
+ &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
+ &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
+ &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
+ &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
+ &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
+ &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
+ &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
+ &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
+ &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
+ &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
+ &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
+ DATA (XUDF_L(K),K= 1483, 1596) /
+ &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
+ &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
+ &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
+ &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
+ &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
+ &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
+ &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
+ &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
+ &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
+ &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
+ &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
+ &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
+ &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
+ &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
+ &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
+ &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
+ &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
+ &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
+ &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
+ DATA (XUDF_L(K),K= 1597, 1710) /
+ &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
+ &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
+ &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
+ &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
+ &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
+ &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
+ &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
+ &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
+ &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
+ &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
+ &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
+ &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
+ &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
+ &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
+ &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
+ &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
+ &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
+ &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
+ &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
+ DATA (XUDF_L(K),K= 1711, 1824) /
+ &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
+ &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
+ &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
+ &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
+ &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
+ &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
+ &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
+ &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
+ &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
+ &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
+ &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
+ &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
+ &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
+ &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
+ &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
+ &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
+ &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
+ &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
+ &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
+ DATA (XUDF_L(K),K= 1825, 1836) /
+ &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
+ &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
+ DATA (XSF_L(K),K= 1, 114) /
+ &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
+ &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
+ &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
+ &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
+ &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
+ &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
+ &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
+ &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
+ &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
+ &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
+ &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
+ &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
+ &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
+ &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
+ &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
+ &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
+ &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
+ &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
+ &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
+ DATA (XSF_L(K),K= 115, 228) /
+ &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
+ &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
+ &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
+ &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
+ &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
+ &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
+ &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
+ &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
+ &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
+ &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
+ &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
+ &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
+ &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
+ &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
+ &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
+ &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
+ &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
+ &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
+ &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
+ DATA (XSF_L(K),K= 229, 342) /
+ &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
+ &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
+ &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
+ &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
+ &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
+ &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
+ &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
+ &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
+ &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
+ &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
+ &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
+ &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
+ &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
+ &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
+ &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
+ &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
+ &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
+ &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
+ &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
+ DATA (XSF_L(K),K= 343, 456) /
+ &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
+ &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
+ &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
+ &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
+ &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
+ &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
+ &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
+ &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
+ &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
+ &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
+ &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
+ &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
+ &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
+ &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
+ &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
+ &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
+ &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
+ &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
+ &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
+ DATA (XSF_L(K),K= 457, 570) /
+ &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
+ &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
+ &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
+ &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
+ &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
+ &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
+ &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
+ &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
+ &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
+ &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
+ &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
+ &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
+ &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
+ &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
+ &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
+ &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
+ &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
+ &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
+ &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
+ DATA (XSF_L(K),K= 571, 684) /
+ &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
+ &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
+ &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
+ &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
+ &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
+ &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
+ &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
+ &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
+ &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
+ &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
+ &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
+ &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
+ &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
+ &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
+ &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
+ &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
+ &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
+ &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
+ &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
+ DATA (XSF_L(K),K= 685, 798) /
+ &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
+ &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
+ &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
+ &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
+ &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
+ &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
+ &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
+ &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
+ &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
+ &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
+ &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
+ &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
+ &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
+ &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
+ &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
+ &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
+ &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
+ &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
+ &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
+ DATA (XSF_L(K),K= 799, 912) /
+ &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
+ &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
+ &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
+ &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
+ &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
+ &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
+ &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
+ &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
+ &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
+ &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
+ &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
+ &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
+ &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
+ &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
+ &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
+ &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
+ &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
+ &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
+ &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
+ DATA (XSF_L(K),K= 913, 1026) /
+ &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
+ &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
+ &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
+ &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
+ &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
+ &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
+ &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
+ &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
+ &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
+ &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
+ &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
+ &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
+ &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
+ &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
+ &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
+ &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
+ &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
+ &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
+ &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
+ DATA (XSF_L(K),K= 1027, 1140) /
+ &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
+ &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
+ &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
+ &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
+ &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
+ &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
+ &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
+ &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
+ &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
+ &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
+ &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
+ &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
+ &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
+ &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
+ &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
+ &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
+ &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
+ &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
+ &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
+ DATA (XSF_L(K),K= 1141, 1254) /
+ &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
+ &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
+ &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
+ &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
+ &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
+ &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
+ &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
+ &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
+ &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
+ &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
+ &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
+ &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
+ &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
+ &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
+ &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
+ &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
+ &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
+ &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
+ &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
+ DATA (XSF_L(K),K= 1255, 1368) /
+ &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
+ &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
+ &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
+ &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
+ &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
+ &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
+ &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
+ &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
+ &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
+ &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
+ &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
+ &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
+ &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
+ &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
+ &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
+ &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
+ &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
+ &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
+ &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
+ DATA (XSF_L(K),K= 1369, 1482) /
+ &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
+ &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
+ &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
+ &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
+ &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
+ &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
+ &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
+ &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
+ &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
+ &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
+ &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
+ &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
+ &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
+ &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
+ &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
+ &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
+ &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
+ &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
+ &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
+ DATA (XSF_L(K),K= 1483, 1596) /
+ &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
+ &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
+ &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
+ &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
+ &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
+ &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
+ &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
+ &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
+ &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
+ &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
+ &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
+ &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
+ &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
+ &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
+ &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
+ &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
+ &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
+ &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
+ &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
+ DATA (XSF_L(K),K= 1597, 1710) /
+ &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
+ &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
+ &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
+ &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
+ &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
+ &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
+ &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
+ &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
+ &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
+ &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
+ &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
+ &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
+ &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
+ &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
+ &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
+ &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
+ &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
+ &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
+ &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
+ DATA (XSF_L(K),K= 1711, 1824) /
+ &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
+ &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
+ &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
+ &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
+ &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
+ &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
+ &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
+ &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
+ &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
+ &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
+ &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
+ &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
+ &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
+ &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
+ &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
+ &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
+ &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
+ &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
+ &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
+ DATA (XSF_L(K),K= 1825, 1836) /
+ &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
+ &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
+ DATA (XGF_L(K),K= 1, 114) /
+ &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
+ &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
+ &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
+ &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
+ &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
+ &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
+ &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
+ &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
+ &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
+ &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
+ &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
+ &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
+ &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
+ &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
+ &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
+ &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
+ &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
+ &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
+ &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
+ DATA (XGF_L(K),K= 115, 228) /
+ &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
+ &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
+ &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
+ &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
+ &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
+ &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
+ &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
+ &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
+ &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
+ &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
+ &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
+ &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
+ &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
+ &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
+ &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
+ &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
+ &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
+ &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
+ &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
+ DATA (XGF_L(K),K= 229, 342) /
+ &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
+ &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
+ &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
+ &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
+ &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
+ &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
+ &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
+ &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
+ &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
+ &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
+ &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
+ &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
+ &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
+ &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
+ &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
+ &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
+ &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
+ &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
+ &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
+ DATA (XGF_L(K),K= 343, 456) /
+ &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
+ &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
+ &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
+ &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
+ &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
+ &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
+ &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
+ &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
+ &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
+ &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
+ &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
+ &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
+ &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
+ &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
+ &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
+ &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
+ &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
+ &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
+ &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
+ DATA (XGF_L(K),K= 457, 570) /
+ &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
+ &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
+ &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
+ &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
+ &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
+ &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
+ &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
+ &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
+ &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
+ &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
+ &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
+ &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
+ &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
+ &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
+ &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
+ &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
+ &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
+ &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
+ &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
+ DATA (XGF_L(K),K= 571, 684) /
+ &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
+ &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
+ &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
+ &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
+ &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
+ &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
+ &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
+ &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
+ &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
+ &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
+ &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
+ &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
+ &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
+ &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
+ &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
+ &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
+ &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
+ &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
+ &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
+ DATA (XGF_L(K),K= 685, 798) /
+ &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
+ &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
+ &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
+ &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
+ &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
+ &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
+ &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
+ &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
+ &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
+ &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
+ &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
+ &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
+ &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
+ &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
+ &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
+ &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
+ &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
+ &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
+ &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
+ DATA (XGF_L(K),K= 799, 912) /
+ &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
+ &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
+ &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
+ &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
+ &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
+ &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
+ &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
+ &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
+ &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
+ &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
+ &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
+ &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
+ &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
+ &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
+ &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
+ &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
+ &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
+ &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
+ &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
+ DATA (XGF_L(K),K= 913, 1026) /
+ &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
+ &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
+ &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
+ &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
+ &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
+ &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
+ &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
+ &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
+ &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
+ &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
+ &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
+ &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
+ &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
+ &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
+ &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
+ &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
+ &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
+ &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
+ &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
+ DATA (XGF_L(K),K= 1027, 1140) /
+ &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
+ &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
+ &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
+ &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
+ &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
+ &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
+ &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
+ &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
+ &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
+ &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
+ &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
+ &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
+ &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
+ &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
+ &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
+ &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
+ &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
+ &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
+ &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
+ DATA (XGF_L(K),K= 1141, 1254) /
+ &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
+ &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
+ &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
+ &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
+ &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
+ &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
+ &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
+ &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
+ &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
+ &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
+ &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
+ &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
+ &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
+ &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
+ &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
+ &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
+ &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
+ &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
+ &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
+ DATA (XGF_L(K),K= 1255, 1368) /
+ &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
+ &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
+ &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
+ &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
+ &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
+ &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
+ &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
+ &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
+ &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
+ &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
+ &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
+ &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
+ &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
+ &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
+ &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
+ &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
+ &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
+ &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
+ &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
+ DATA (XGF_L(K),K= 1369, 1482) /
+ &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
+ &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
+ &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
+ &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
+ &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
+ &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
+ &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
+ &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
+ &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
+ &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
+ &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
+ &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
+ &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
+ &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
+ &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
+ &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
+ &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
+ &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
+ &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
+ DATA (XGF_L(K),K= 1483, 1596) /
+ &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
+ &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
+ &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
+ &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
+ &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
+ &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
+ &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
+ &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
+ &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
+ &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
+ &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
+ &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
+ &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
+ &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
+ &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
+ &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
+ &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
+ &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
+ &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
+ DATA (XGF_L(K),K= 1597, 1710) /
+ &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
+ &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
+ &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
+ &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
+ &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
+ &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
+ &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
+ &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
+ &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
+ &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
+ &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
+ &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
+ &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
+ &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
+ &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
+ &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
+ &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
+ &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
+ &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
+ DATA (XGF_L(K),K= 1711, 1824) /
+ &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
+ &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
+ &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
+ &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
+ &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
+ &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
+ &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
+ &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
+ &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
+ &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
+ &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
+ &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
+ &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
+ &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
+ &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
+ &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
+ &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
+ &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
+ &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
+ DATA (XGF_L(K),K= 1825, 1836) /
+ &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
+ &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
+
+*
+ X = Xinp
+*...CHECK OF X AND Q2 VALUES :
+ IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
+* WRITE(LO,91) X
+ 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
+ X = 0.99D-9
+* STOP
+ ENDIF
+
+ Q2 = Q2inp
+ IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
+* WRITE(LO,92) Q2
+ 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
+ Q2 = 0.99E6
+* STOP
+ ENDIF
+
+*
+*...INTERPOLATION :
+ NA(1) = NX
+ NA(2) = NQ
+ XT(1) = DLOG(X)
+ XT(2) = DLOG(Q2)
+ X1 = 1.- X
+ XV = X**0.5
+ XS = X**(-0.2)
+ UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
+ DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
+ DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
+ UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
+ US = 0.5 * (UD - DE)
+ DS = 0.5 * (UD + DE)
+ SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
+ GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
+
+ END
+
+*$ CREATE PHO_DOR98SC.FOR
+*COPY PHO_DOR98SC
+CDECK ID>, PHO_DOR98SC
+ SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
+C***********************************************************************
+C
+C GRV98 parton densities, leading order set
+C
+C For a detailed explanation see
+C M. Glueck, E. Reya, A. Vogt :
+C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
+C (To appear in Eur. Phys. J. C)
+C
+C interpolation routine based on the original GRV98PA routine,
+C adapted to define interpolation table as DATA statements
+C
+C (R.Engel, 09/98)
+C
+C CAUTION: this is a version with gluon shadowing corrections
+C (R.Engel, 09/99)
+C
+C
+C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
+C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
+C
+C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
+C DS = d(bar), SS = s = s(bar), GL = gluon.
+C Always x times the distribution is returned.
+C
+C******************************************************i****************
+ IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
+ DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
+ 1 XSF(NX,NQ), XGF(NX,NQ),
+ 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
+
+ DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
+ & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
+
+ EQUIVALENCE (XUVF(1,1),XUVF_L(1))
+ EQUIVALENCE (XDVF(1,1),XDVF_L(1))
+ EQUIVALENCE (XDEF(1,1),XDEF_L(1))
+ EQUIVALENCE (XUDF(1,1),XUDF_L(1))
+ EQUIVALENCE (XSF(1,1),XSF_L(1))
+ EQUIVALENCE (XGF(1,1),XGF_L(1))
+
+*#################### data statements for shadowed LO PDF ##############
+C ... deleted ...
+*#######################################################################
+
+ X = Xinp
+*...CHECK OF X AND Q2 VALUES :
+ IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
+* WRITE(LO,91) X
+ 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
+ X = 0.99D-9
+* STOP
+ ENDIF
+
+ Q2 = Q2inp
+ IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
+* WRITE(LO,92) Q2
+ 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
+ Q2 = 0.99E6
+* STOP
+ ENDIF
+
+*
+*...INTERPOLATION :
+ NA(1) = NX
+ NA(2) = NQ
+ XT(1) = DLOG(X)
+ XT(2) = DLOG(Q2)
+ X1 = 1.- X
+ XV = X**0.5
+ XS = X**(-0.2)
+ UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
+ DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
+ DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
+ UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
+ US = 0.5 * (UD - DE)
+ DS = 0.5 * (UD + DE)
+ SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
+ GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
+
+ END
+
+*$ CREATE PHO_DOR94LO.FOR
+*COPY PHO_DOR94LO
+CDECK ID>, PHO_DOR94LO
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* 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 *
+* *
+* 1994 UPDATE *
+* *
+* FOR A DETAILED EXPLANATION SEE *
+* M. GLUECK, E.REYA, A.VOGT : *
+* DO-TH 94/24 = DESY 94-206 *
+* (TO APPEAR IN Z. PHYS. C) *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
+* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
+* X BETWEEN 1.E-5 AND 1. *
+* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
+* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
+* M(C) = 1.5, M(B) = 4.5 *
+* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, *
+* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131. *
+* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
+* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
+* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
+* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
+* GRV PARAMETRIZATION. *
+* *
+* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
+* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
+* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+*
+*...INPUT PARAMETERS :
+*
+* X = MOMENTUM FRACTION
+* Q2 = SCALE Q**2 IN GEV**2
+*
+*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
+*
+* UV = U(VAL) = U - U(BAR)
+* DV = D(VAL) = D - D(BAR)
+* DEL = D(BAR) - U(BAR)
+* UDB = U(BAR) + D(BAR)
+* SB = S = S(BAR)
+* GL = GLUON
+*
+*...LO PARAMETRIZATION :
+*
+ SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.23
+ LAM2 = 0.2322 * 0.2322
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 2.284 + 0.802 * S + 0.055 * S2
+ AKU = 0.590 - 0.024 * S
+ BKU = 0.131 + 0.063 * S
+ AU = -0.449 - 0.138 * S - 0.076 * S2
+ BU = 0.213 + 2.669 * S - 0.728 * S2
+ CU = 8.854 - 9.135 * S + 1.979 * S2
+ DU = 2.997 + 0.753 * S - 0.076 * S2
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.371 + 0.083 * S + 0.039 * S2
+ AKD = 0.376
+ BKD = 0.486 + 0.062 * S
+ AD = -0.509 + 3.310 * S - 1.248 * S2
+ BD = 12.41 - 10.52 * S + 2.267 * S2
+ CD = 6.373 - 6.208 * S + 1.418 * S2
+ DD = 3.691 + 0.799 * S - 0.071 * S2
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.082 + 0.014 * S + 0.008 * S2
+ AKE = 0.409 - 0.005 * S
+ BKE = 0.799 + 0.071 * S
+ AE = -38.07 + 36.13 * S - 0.656 * S2
+ BE = 90.31 - 74.15 * S + 7.645 * S2
+ CE = 0.0
+ DE = 7.486 + 1.217 * S - 0.159 * S2
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 1.451
+ BEX = 0.271
+ AKX = 0.410 - 0.232 * S
+ BKX = 0.534 - 0.457 * S
+ AGX = 0.890 - 0.140 * S
+ BGX = -0.981
+ CX = 0.320 + 0.683 * S
+ DX = 4.752 + 1.164 * S + 0.286 * S2
+ EX = 4.119 + 1.713 * S
+ ESX = 0.682 + 2.978 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.914
+ BES = 0.577
+ AKS = 1.798 - 0.596 * S
+ AS = -5.548 + 3.669 * DS - 0.616 * S
+ BS = 18.92 - 16.73 * DS + 5.168 * S
+ DST = 6.379 - 0.350 * S + 0.142 * S2
+ EST = 3.981 + 1.638 * S
+ ESS = 6.402
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 0.524
+ BEG = 1.088
+ AKG = 1.742 - 0.930 * S
+ BKG = - 0.399 * S2
+ AG = 7.486 - 2.185 * S
+ BG = 16.69 - 22.74 * S + 5.779 * S2
+ CG = -25.59 + 29.71 * S - 7.296 * S2
+ DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
+ EG = 0.807 + 2.005 * S
+ ESG = 3.841 + 0.316 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+*
+*...NLO PARAMETRIZATION (MS(BAR)) :
+*
+*$ CREATE PHO_DOR94HO.FOR
+*COPY PHO_DOR94HO
+CDECK ID>, PHO_DOR94HO
+ SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.34
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 1.304 + 0.863 * S
+ AKU = 0.558 - 0.020 * S
+ BKU = 0.183 * S
+ AU = -0.113 + 0.283 * S - 0.321 * S2
+ BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
+ CU = 7.771 - 10.09 * S + 2.630 * S2
+ DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.102 - 0.017 * S + 0.005 * S2
+ AKD = 0.270 - 0.019 * S
+ BKD = 0.260
+ AD = 2.393 + 6.228 * S - 0.881 * S2
+ BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
+ CD = 17.83 - 53.47 * S + 21.24 * S2
+ DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
+ AKE = 0.409 - 0.007 * S
+ BKE = 0.782 + 0.082 * S
+ AE = -29.65 + 26.49 * S + 5.429 * S2
+ BE = 90.20 - 74.97 * S + 4.526 * S2
+ CE = 0.0
+ DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 0.877
+ BEX = 0.561
+ AKX = 0.275
+ BKX = 0.0
+ AGX = 0.997
+ BGX = 3.210 - 1.866 * S
+ CX = 7.300
+ DX = 9.010 + 0.896 * DS + 0.222 * S2
+ EX = 3.077 + 1.446 * S
+ ESX = 3.173 - 2.445 * DS + 2.207 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.756
+ BES = 0.216
+ AKS = 1.690 + 0.650 * DS - 0.922 * S
+ AS = -4.329 + 1.131 * S
+ BS = 9.568 - 1.744 * S
+ DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
+ EST = 3.031 + 1.639 * S
+ ESS = 5.837 + 0.815 * S
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 1.014
+ BEG = 1.738
+ AKG = 1.724 + 0.157 * S
+ BKG = 0.800 + 1.016 * S
+ AG = 7.517 - 2.547 * S
+ BG = 34.09 - 52.21 * DS + 17.47 * S
+ CG = 4.039 + 1.491 * S
+ DG = 3.404 + 0.830 * S
+ EG = -1.112 + 3.438 * S - 0.302 * S2
+ ESG = 3.256 - 0.436 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+*$ CREATE PHO_DOR94DI.FOR
+*COPY PHO_DOR94DI
+CDECK ID>, PHO_DOR94DI
+*
+*...NLO PARAMETRIZATION (DIS) :
+*
+ SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.34
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 2.484 + 0.116 * S + 0.093 * S2
+ AKU = 0.563 - 0.025 * S
+ BKU = 0.054 + 0.154 * S
+ AU = -0.326 - 0.058 * S - 0.135 * S2
+ BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
+ CU = 11.52 - 12.99 * S + 3.161 * S2
+ DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.156 - 0.017 * S
+ AKD = 0.299 - 0.022 * S
+ BKD = 0.259 - 0.015 * S
+ AD = 3.445 + 1.278 * S + 0.326 * S2
+ BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
+ CD = 55.45 - 69.92 * S + 20.78 * S2
+ DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.099 + 0.019 * S + 0.002 * S2
+ AKE = 0.419 - 0.013 * S
+ BKE = 1.064 - 0.038 * S
+ AE = -44.00 + 98.70 * S - 14.79 * S2
+ BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
+ CE = 84.57 - 108.8 * S + 31.52 * S2
+ DE = 7.469 + 2.480 * S - 0.866 * S2
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 1.215
+ BEX = 0.466
+ AKX = 0.326 + 0.150 * S
+ BKX = 0.956 + 0.405 * S
+ AGX = 0.272
+ BGX = 3.794 - 2.359 * DS
+ CX = 2.014
+ DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
+ EX = 3.049 + 1.597 * S
+ ESX = 4.396 - 4.594 * DS + 3.268 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.175
+ BES = 0.344
+ AKS = 1.415 - 0.641 * DS
+ AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
+ BS = 5.617 + 5.709 * DS - 3.972 * S
+ DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
+ EST = 4.546 + 0.372 * S2
+ ESS = 5.053 - 1.070 * S + 0.805 * S2
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 1.258
+ BEG = 1.846
+ AKG = 2.423
+ BKG = 2.427 + 1.311 * S - 0.153 * S2
+ AG = 25.09 - 7.935 * S
+ BG = -14.84 - 124.3 * DS + 72.18 * S
+ CG = 590.3 - 173.8 * S
+ DG = 5.196 + 1.857 * S
+ EG = -1.648 + 3.988 * S - 0.432 * S2
+ ESG = 3.232 - 0.542 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+*
+*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
+*
+*$ CREATE PHO_DOR94FV.FOR
+*COPY PHO_DOR94FV
+CDECK ID>, PHO_DOR94FV
+ DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
+
+ END
+
+*$ CREATE PHO_DOR94FW.FOR
+*COPY PHO_DOR94FW
+CDECK ID>, PHO_DOR94FW
+ DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
+ & A,B,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ LX = LOG (1./X)
+ PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
+ 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DOR94FS.FOR
+*COPY PHO_DOR94FS
+CDECK ID>, PHO_DOR94FS
+ DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
+ 1 * DEXP (-E + SQRT (ES * S**BE * LX))
+
+ END
+
+*$ CREATE PHO_DOR92LO.FOR
+*COPY PHO_DOR92LO
+CDECK ID>, PHO_DOR92LO
+*
+*
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* 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 *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
+* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ S2 = S * S
+ S3 = S2 * S
+C...X * (UV + DV) :
+ NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
+ AKUD = 0.326
+ AGUD = -1.97 + 6.74 * S - 1.96 * S2
+ BUD = 24.4 - 20.7 * S + 4.08 * S2
+ DUD = 2.86 + 0.70 * S - 0.02 * S2
+ UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
+C...X * DV :
+ ND = 0.579 + 0.283 * S + 0.047 * S2
+ AKD = 0.523 - 0.015 * S
+ AGD = 2.22 - 0.59 * S - 0.27 * S2
+ BD = 5.95 - 6.19 * S + 1.55 * S2
+ DD = 3.57 + 0.94 * S - 0.16 * S2
+ DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
+C...X * G :
+ ALG = 0.558
+ BEG = 1.218
+ AKG = 1.00 - 0.17 * S
+ BKG = 0.0
+ AGG = 0.0 + 4.879 * S - 1.383 * S2
+ BGG = 25.92 - 28.97 * S + 5.596 * S2
+ CG = -25.69 + 23.68 * S - 1.975 * S2
+ DG = 2.537 + 1.718 * S + 0.353 * S2
+ EG = 0.595 + 2.138 * S
+ ESG = 4.066
+ GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * UBAR = X * DBAR :
+ ALU = 1.396
+ BEU = 1.331
+ AKU = 0.412 - 0.171 * S
+ BKU = 0.566 - 0.496 * S
+ AGU = 0.363
+ BGU = -1.196
+ CU = 1.029 + 1.785 * S - 0.459 * S2
+ DU = 4.696 + 2.109 * S
+ EU = 3.838 + 1.944 * S
+ ESU = 2.845
+ UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
+C...X * SBAR = X * S :
+ SS = 0.0
+ ALS = 0.803
+ BES = 0.563
+ AKS = 2.082 - 0.577 * S
+ AGS = -3.055 + 1.024 * S ** 0.67
+ BS = 27.4 - 20.0 * S ** 0.154
+ DS = 6.22
+ EST = 4.33 + 1.408 * S
+ ESS = 8.27 - 0.437 * S
+ SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+*$ CREATE PHO_DOR92HO.FOR
+*COPY PHO_DOR92HO
+CDECK ID>, PHO_DOR92HO
+ SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+C...X * (UV + DV) :
+ NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
+ AKUD = 0.285
+ AGUD = -2.28 + 15.73 * S - 4.58 * S2
+ BUD = 56.7 - 53.6 * S + 11.21 * S2
+ DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
+ UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
+C...X * DV :
+ ND = 0.459 + 0.315 * DS + 0.515 * S
+ AKD = 0.624 - 0.031 * S
+ AGD = 8.13 - 6.77 * DS + 0.46 * S
+ BD = 6.59 - 12.83 * DS + 5.65 * S
+ DD = 3.98 + 1.04 * S - 0.34 * S2
+ DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
+C...X * G :
+ ALG = 1.128
+ BEG = 1.575
+ AKG = 0.323 + 1.653 * S
+ BKG = 0.811 + 2.044 * S
+ AGG = 0.0 + 1.963 * S - 0.519 * S2
+ BGG = 0.078 + 6.24 * S
+ CG = 30.77 - 24.19 * S
+ DG = 3.188 + 0.720 * S
+ EG = -0.881 + 2.687 * S
+ ESG = 2.466
+ GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * UBAR = X * DBAR :
+ ALU = 0.594
+ BEU = 0.614
+ AKU = 0.636 - 0.084 * S
+ BKU = 0.0
+ AGU = 1.121 - 0.193 * S
+ BGU = 0.751 - 0.785 * S
+ CU = 8.57 - 1.763 * S
+ DU = 10.22 + 0.668 * S
+ EU = 3.784 + 1.280 * S
+ ESU = 1.808 + 0.980 * S
+ UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
+C...X * SBAR = X * S :
+ SS = 0.0
+ ALS = 0.756
+ BES = 0.101
+ AKS = 2.942 - 1.016 * S
+ AGS = -4.60 + 1.167 * S
+ BS = 9.31 - 1.324 * S
+ DS = 11.49 - 1.198 * S + 0.053 * S2
+ EST = 2.630 + 1.729 * S
+ ESS = 8.12
+ SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+*$ CREATE PHO_DOR92FV.FOR
+*COPY PHO_DOR92FV
+CDECK ID>, PHO_DOR92FV
+ DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+ DX = SQRT (X)
+ PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DOR92FW.FOR
+*COPY PHO_DOR92FW
+CDECK ID>, PHO_DOR92FW
+ DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
+ & AL,BE,AK,BK,AG,BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+ LX = LOG (1./X)
+ PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DOR92FS.FOR
+*COPY PHO_DOR92FS
+CDECK ID>, PHO_DOR92FS
+ DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ IF (S .LE. ST) THEN
+ PHO_DOR92FS = 0.D0
+ ELSE
+ PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))
+ END IF
+
+ END
+
+*$ CREATE PHO_DORPLO.FOR
+*COPY PHO_DORPLO
+CDECK ID>, PHO_DORPLO
+*
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P I O N - P A R A M E T R I Z A T I O N S *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
+* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.519 + 0.180 * S - 0.011 * S2
+ AKV = 0.499 - 0.027 * S
+ AGV = 0.381 - 0.419 * S
+ DV = 0.367 + 0.563 * S
+ VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 0.599
+ BEG = 1.263
+ AKG = 0.482 + 0.341 * DS
+ BKG = 0.0
+ AGG = 0.678 + 0.877 * S - 0.175 * S2
+ BGG = 0.338 - 1.597 * S
+ CG = 0.0 - 0.233 * S + 0.406 * S2
+ DG = 0.390 + 1.053 * S
+ EG = 0.618 + 2.070 * S
+ ESG = 3.676
+ GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0
+ ALS = 0.55
+ BES = 0.56
+ AKS = 2.538 - 0.763 * S
+ AGS = -0.748
+ BS = 0.313 + 0.935 * S
+ DS = 3.359
+ EST = 4.433 + 1.301 * S
+ ESS = 9.30 - 0.887 * S
+ QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.888
+ ALC = 1.02
+ BEC = 0.39
+ AKC = 0.0
+ AGC = 0.0
+ BC = 1.008
+ DC = 1.208 + 0.771 * S
+ EC = 4.40 + 1.493 * S
+ ESC = 2.032 + 1.901 * S
+ CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.351
+ ALB = 1.03
+ BEB = 0.39
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 0.0
+ DB = 0.697 + 0.855 * S
+ EB = 4.51 + 1.490 * S
+ ESB = 3.056 + 1.694 * S
+ BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+*$ CREATE PHO_DORPHO.FOR
+*COPY PHO_DORPHO
+CDECK ID>, PHO_DORPHO
+ SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
+ AKV = 0.505 - 0.033 * S
+ AGV = 0.748 - 0.669 * DS - 0.133 * S
+ DV = 0.365 + 0.197 * DS + 0.394 * S
+ VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 1.096
+ BEG = 1.371
+ AKG = 0.437 - 0.689 * DS
+ BKG = -0.631
+ AGG = 1.324 - 0.441 * DS - 0.130 * S
+ BGG = -0.955 + 0.259 * S
+ CG = 1.075 - 0.302 * S
+ DG = 1.158 + 1.229 * S
+ EG = 0.0 + 2.510 * S
+ ESG = 2.604 + 0.165 * S
+ GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0
+ ALS = 0.85
+ BES = 0.96
+ AKS = -0.350 + 0.806 * S
+ AGS = -1.663
+ BS = 3.148
+ DS = 2.273 + 1.438 * S
+ EST = 3.214 + 1.545 * S
+ ESS = 1.341 + 1.938 * S
+ QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = 0.0 - 0.457 * S
+ AGC = 0.0
+ BC = -1.00 + 1.40 * S
+ DC = 1.318 + 0.584 * S
+ EC = 4.45 + 1.235 * S
+ ESC = 1.496 + 1.010 * S
+ CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.172 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 1.447 + 0.485 * S
+ EB = 4.79 + 1.164 * S
+ ESB = 1.724 + 2.121 * S
+ BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+*$ CREATE PHO_DORFVP.FOR
+*COPY PHO_DORFVP
+CDECK ID>, PHO_DORFVP
+ DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DORFGP.FOR
+*COPY PHO_DORFGP
+CDECK ID>, PHO_DORFGP
+ DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
+ & BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DORFQP.FOR
+*COPY PHO_DORFQP
+CDECK ID>, PHO_DORFQP
+ DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ IF (S .LE. ST) THEN
+ PHO_DORFQP = 0.0
+ ELSE
+ PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))
+ END IF
+
+ END
+
+*$ CREATE PHO_DORGLO.FOR
+*COPY PHO_DORGLO
+CDECK ID>, PHO_DORGLO
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* 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 *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
+* *
+* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 1.717
+ BE = 0.641
+ AK = 0.500 - 0.176 * S
+ BK = 15.00 - 5.687 * SS - 0.552 * S2
+ AG = 0.235 + 0.046 * SS
+ BG = 0.082 - 0.051 * S + 0.168 * S2
+ C = 0.0 + 0.459 * S
+ D = 0.354 - 0.061 * S
+ E = 4.899 + 1.678 * S
+ ES = 2.046 + 1.389 * S
+ UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 1.549
+ BE = 0.782
+ AK = 0.496 + 0.026 * S
+ BK = 0.685 - 0.580 * SS + 0.608 * S2
+ AG = 0.233 + 0.302 * S
+ BG = 0.0 - 0.818 * S + 0.198 * S2
+ C = 0.114 + 0.154 * S
+ D = 0.405 - 0.195 * S + 0.046 * S2
+ E = 4.807 + 1.226 * S
+ ES = 2.166 + 0.664 * S
+ DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 0.676
+ BE = 1.089
+ AK = 0.462 - 0.524 * SS
+ BK = 5.451 - 0.804 * S2
+ AG = 0.535 - 0.504 * SS + 0.288 * S2
+ BG = 0.364 - 0.520 * S
+ C = -0.323 + 0.115 * S2
+ D = 0.233 + 0.790 * S - 0.139 * S2
+ E = 0.893 + 1.968 * S
+ ES = 3.432 + 0.392 * S
+ GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 1.609
+ BE = 0.962
+ AK = 0.470 - 0.099 * S2
+ BK = 3.246
+ AG = 0.121 - 0.068 * SS
+ BG = -0.090 + 0.074 * S
+ C = 0.062 + 0.034 * S
+ D = 0.0 + 0.226 * S - 0.060 * S2
+ E = 4.288 + 1.707 * S
+ ES = 2.122 + 0.656 * S
+ SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.888
+ AL = 0.970
+ BE = 0.545
+ AK = 1.254 - 0.251 * S
+ BK = 3.932 - 0.327 * S2
+ AG = 0.658 + 0.202 * S
+ BG = -0.699
+ C = 0.965
+ D = 0.0 + 0.141 * S - 0.027 * S2
+ E = 4.911 + 0.969 * S
+ ES = 2.796 + 0.952 * S
+ CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.351
+ AL = 1.016
+ BE = 0.338
+ AK = 1.961 - 0.370 * S
+ BK = 0.923 + 0.119 * S
+ AG = 0.815 + 0.207 * S
+ BG = -2.275
+ C = 1.480
+ D = -0.223 + 0.173 * S
+ E = 5.426 + 0.623 * S
+ ES = 3.819 + 0.901 * S
+ BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+*$ CREATE PHO_DORGHO.FOR
+*COPY PHO_DORGHO
+CDECK ID>, PHO_DORGHO
+ SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 0.583
+ BE = 0.688
+ AK = 0.449 - 0.025 * S - 0.071 * S2
+ BK = 5.060 - 1.116 * SS
+ AG = 0.103
+ BG = 0.319 + 0.422 * S
+ C = 1.508 + 4.792 * S - 1.963 * S2
+ D = 1.075 + 0.222 * SS - 0.193 * S2
+ E = 4.147 + 1.131 * S
+ ES = 1.661 + 0.874 * S
+ UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 0.591
+ BE = 0.698
+ AK = 0.442 - 0.132 * S - 0.058 * S2
+ BK = 5.437 - 1.916 * SS
+ AG = 0.099
+ BG = 0.311 - 0.059 * S
+ C = 0.800 + 0.078 * S - 0.100 * S2
+ D = 0.862 + 0.294 * SS - 0.184 * S2
+ E = 4.202 + 1.352 * S
+ ES = 1.841 + 0.990 * S
+ DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 1.161
+ BE = 1.591
+ AK = 0.530 - 0.742 * SS + 0.025 * S2
+ BK = 5.662
+ AG = 0.533 - 0.281 * SS + 0.218 * S2
+ BG = 0.025 - 0.518 * S + 0.156 * S2
+ C = -0.282 + 0.209 * S2
+ D = 0.107 + 1.058 * S - 0.218 * S2
+ E = 0.0 + 2.704 * S
+ ES = 3.071 - 0.378 * S
+ GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 0.635
+ BE = 0.456
+ AK = 1.770 - 0.735 * SS - 0.079 * S2
+ BK = 3.832
+ AG = 0.084 - 0.023 * S
+ BG = 0.136
+ C = 2.119 - 0.942 * S + 0.063 * S2
+ D = 1.271 + 0.076 * S - 0.190 * S2
+ E = 4.604 + 0.737 * S
+ ES = 1.641 + 0.976 * S
+ SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.820
+ AL = 0.926
+ BE = 0.152
+ AK = 1.142 - 0.175 * S
+ BK = 3.276
+ AG = 0.504 + 0.317 * S
+ BG = -0.433
+ C = 3.334
+ D = 0.398 + 0.326 * S - 0.107 * S2
+ E = 5.493 + 0.408 * S
+ ES = 2.426 + 1.277 * S
+ CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.297
+ AL = 0.969
+ BE = 0.266
+ AK = 1.953 - 0.391 * S
+ BK = 1.657 - 0.161 * S
+ AG = 1.076 + 0.034 * S
+ BG = -2.015
+ C = 1.662
+ D = 0.353 + 0.016 * S
+ E = 5.713 + 0.249 * S
+ ES = 3.456 + 0.673 * S
+ BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+*$ CREATE PHO_DORGH0.FOR
+*COPY PHO_DORGH0
+CDECK ID>, PHO_DORGH0
+ SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 1.447
+ BE = 0.848
+ AK = 0.527 + 0.200 * S - 0.107 * S2
+ BK = 7.106 - 0.310 * SS - 0.786 * S2
+ AG = 0.197 + 0.533 * S
+ BG = 0.062 - 0.398 * S + 0.109 * S2
+ C = 0.755 * S - 0.112 * S2
+ D = 0.318 - 0.059 * S
+ E = 4.225 + 1.708 * S
+ ES = 1.752 + 0.866 * S
+ U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 1.424
+ BE = 0.770
+ AK = 0.500 + 0.067 * SS - 0.055 * S2
+ BK = 0.376 - 0.453 * SS + 0.405 * S2
+ AG = 0.156 + 0.184 * S
+ BG = 0.0 - 0.528 * S + 0.146 * S2
+ C = 0.121 + 0.092 * S
+ D = 0.379 - 0.301 * S + 0.081 * S2
+ E = 4.346 + 1.638 * S
+ ES = 1.645 + 1.016 * S
+ D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 0.661
+ BE = 0.793
+ AK = 0.537 - 0.600 * SS
+ BK = 6.389 - 0.953 * S2
+ AG = 0.558 - 0.383 * SS + 0.261 * S2
+ BG = 0.0 - 0.305 * S
+ C = -0.222 + 0.078 * S2
+ D = 0.153 + 0.978 * S - 0.209 * S2
+ E = 1.429 + 1.772 * S
+ ES = 3.331 + 0.806 * S
+ G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 1.578
+ BE = 0.863
+ AK = 0.622 + 0.332 * S - 0.300 * S2
+ BK = 2.469
+ AG = 0.211 - 0.064 * SS - 0.018 * S2
+ BG = -0.215 + 0.122 * S
+ C = 0.153
+ D = 0.0 + 0.253 * S - 0.081 * S2
+ E = 3.990 + 2.014 * S
+ ES = 1.720 + 0.986 * S
+ S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.820
+ AL = 0.929
+ BE = 0.381
+ AK = 1.228 - 0.231 * S
+ BK = 3.806 - 0.337 * S2
+ AG = 0.932 + 0.150 * S
+ BG = -0.906
+ C = 1.133
+ D = 0.0 + 0.138 * S - 0.028 * S2
+ E = 5.588 + 0.628 * S
+ ES = 2.665 + 1.054 * S
+ C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.297
+ AL = 0.970
+ BE = 0.207
+ AK = 1.719 - 0.292 * S
+ BK = 0.928 + 0.096 * S
+ AG = 0.845 + 0.178 * S
+ BG = -2.310
+ C = 1.558
+ D = -0.191 + 0.151 * S
+ E = 6.089 + 0.282 * S
+ ES = 3.379 + 1.062 * S
+ B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+*$ CREATE PHO_DORGF.FOR
+*COPY PHO_DORGF
+CDECK ID>, PHO_DORGF
+ DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
+ & AG,BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ SX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+*$ CREATE PHO_DORGFS.FOR
+*COPY PHO_DORGFS
+CDECK ID>, PHO_DORGFS
+ DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
+ & C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ IF (S .LE. SF) THEN
+ PHO_DORGFS = 0.0
+ ELSE
+ SX = SQRT (X)
+ LX = LOG (1./X)
+ DS = S - SF
+ PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+ END IF
+
+ END
+
+*$ CREATE PHO_DORGLV.FOR
+*COPY PHO_DORGLV
+CDECK ID>, PHO_DORGLV
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
+* *
+* FOR A DETAILED EXPLANATION SEE *
+* M. GLUECK, E.REYA, M. STRATMANN : *
+* PHYS. REV. D51 (1995) 3220 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
+* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
+* AND (!) Q**2 > 5 P**2 *
+* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
+* P**2 = 0 <=> REAL PHOTON *
+* X BETWEEN 1.E-4 AND 1. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
+* M(C) = 1.5, M(B) = 4.5 *
+* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, *
+* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
+* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
+* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
+* *
+* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
+* Marco.Stratmann@durham.ac.uk *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+*
+*...INPUT PARAMETERS :
+*
+* X = MOMENTUM FRACTION
+* Q2 = SCALE Q**2 IN GEV**2
+* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
+*
+*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
+*
+********************************************************
+* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
+ subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
+ implicit double precision (a-z)
+ save
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer check
+c
+c check limits :
+c
+ check=0
+ if(x.lt.0.0001d0) check=1
+ if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
+ if(q2.lt.5.d0*p2) check=1
+c
+c calculate distributions
+c
+ if(check.eq.0) then
+ call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
+ else
+ WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
+ WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
+ endif
+
+ end
+
+*$ CREATE PHO_grscalc.FOR
+*COPY PHO_grscalc
+CDECK ID>, PHO_grscalc
+ subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
+ implicit double precision (a-z)
+ save
+
+ dimension u1(40),ds1(40),g1(40)
+ dimension ud2(20),s2(20),g2(20)
+ dimension up0(20),dsp0(20),gp0(20)
+**sr
+C save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
+**
+c
+ data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
+ & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
+ & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
+ & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
+ & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
+ & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
+ & 0.622d0,0.227d0,-0.184d0/
+ data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
+ & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
+ & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
+ & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
+ & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
+ & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
+ & 0.245d0,-0.171d0/
+ data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
+ & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
+ & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
+ & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
+ & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
+ & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
+ data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
+ & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
+ & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
+ & -0.614d0,3.548d0/
+ data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
+ & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
+ & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
+ & -0.48d0,3.401d0/
+ data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
+ & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
+ & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
+ & -0.079d0/
+ data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
+ & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
+ & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
+ & 2.294d0/
+ data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
+ & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
+ & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
+ & 0.814d0,1.531d0,0.124d0/
+ data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
+ & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
+ & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
+ & 2.264d0,0.2675d0/
+c
+ mu2=0.25d0
+ lam2=0.232d0*0.232d0
+c
+ if(p2.le.0.25d0) then
+ s=log(log(q2/lam2)/log(mu2/lam2))
+ lp1=0.d0
+ lp2=0.d0
+ else
+ s=log(log(q2/lam2)/log(p2/lam2))
+ lp1=log(p2/mu2)*log(p2/mu2)
+ lp2=log(p2/mu2+log(p2/mu2))
+ endif
+c
+ alp=up0(1)+lp1*u1(1)+lp2*u1(2)
+ bet=up0(2)+lp1*u1(3)+lp2*u1(4)
+ a=up0(3)+lp1*u1(5)+lp2*u1(6)+
+ & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
+ b=up0(5)+lp1*u1(9)+lp2*u1(10)+
+ & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
+ & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
+ gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
+ & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
+ & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
+ ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
+ & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
+ gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
+ & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
+ gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
+ & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
+ ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
+ & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
+ gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
+ & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
+ upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
+ bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
+ a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
+ & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
+ b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
+ & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
+ & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
+ gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
+ & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
+ & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
+ ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
+ & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
+ gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
+ & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
+ gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
+ & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
+ ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
+ & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
+ gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
+ & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
+ dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
+ bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
+ a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
+ & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
+ b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
+ & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
+ gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
+ & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
+ ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
+ & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
+ & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
+ gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
+ & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
+ gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
+ & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
+ & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
+ ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
+ & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
+ gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
+ & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
+ gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ s=log(log(q2/lam2)/log(mu2/lam2))
+ suppr=1.d0/(1.d0+p2/0.59d0)**2
+c
+ alp=ud2(1)
+ bet=ud2(2)
+ a=ud2(3)+ud2(4)*s
+ ga=ud2(5)+ud2(6)*s**0.5
+ gc=ud2(7)+ud2(8)*s
+ b=ud2(9)+ud2(10)*s+ud2(11)*s**2
+ gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
+ gd=ud2(15)+ud2(16)*s
+ ge=ud2(17)+ud2(18)*s
+ gep=ud2(19)+ud2(20)*s
+ udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=s2(1)
+ bet=s2(2)
+ a=s2(3)+s2(4)*s
+ ga=s2(5)+s2(6)*s**0.5
+ gc=s2(7)+s2(8)*s
+ b=s2(9)+s2(10)*s+s2(11)*s**2
+ gb=s2(12)+s2(13)*s+s2(14)*s**2
+ gd=s2(15)+s2(16)*s
+ ge=s2(17)+s2(18)*s
+ gep=s2(19)+s2(20)*s
+ spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=g2(1)
+ bet=g2(2)
+ a=g2(3)+g2(4)*s**0.5
+ b=g2(5)+g2(6)*s**2
+ gb=g2(7)+g2(8)*s
+ ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
+ gc=g2(12)+g2(13)*s**2
+ gd=g2(14)+g2(15)*s+g2(16)*s**2
+ ge=g2(17)+g2(18)*s
+ gep=g2(19)+g2(20)*s
+ gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ ugam=upart1+udpart2
+ dgam=dspart1+udpart2
+ sgam=dspart1+spart2
+ ggam=gpart1+gpart2
+c
+ end
+
+*$ CREATE PHO_grsf1.FOR
+*COPY PHO_grsf1
+CDECK ID>, PHO_grsf1
+ DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
+ & ge,gep)
+ implicit double precision (a-z)
+ save
+
+ PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
+ & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
+ & (1.d0-x)**gd
+
+ end
+
+*$ CREATE PHO_grsf2.FOR
+*COPY PHO_grsf2
+CDECK ID>, PHO_grsf2
+ DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
+ & ge,gep)
+ implicit double precision (a-z)
+ save
+
+ PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
+ & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
+ & (1.d0-x)**gd
+
+ end
+
+*$ CREATE PHO_CKMTPA.FOR
+*COPY PHO_CKMTPA
+CDECK ID>, PHO_CKMTPA
+ SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 990 Pomeron
+C
+C output: parameters of parametrization
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CHARACTER*8 PDFNA
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ REAL PROP(40),POMP(40)
+ DATA PROP /
+ & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
+ & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
+ & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
+ DATA POMP /
+ & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
+ & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
+ & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
+
+ IF(IPA.EQ.2212) THEN
+ ALA =PROP(1)
+ Q2MI = PROP(39)
+ Q2MA = PROP(40)
+ PDFNA = 'CKMT-PRO'
+ ELSE IF(IPA.EQ.990) THEN
+ ALA = POMP(1)
+ Q2MI = POMP(39)
+ Q2MA = POMP(40)
+ PDFNA = 'CKMT-POM'
+ ELSE
+ WRITE(LO,'(1X,A,I7)')
+ & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
+ STOP
+ ENDIF
+ XMI = 1.D-4
+ XMA = 1.D0
+ END
+
+*$ CREATE PHO_CKMTPD.FOR
+*COPY PHO_CKMTPD
+CDECK ID>, PHO_CKMTPD
+ SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 990 Pomeron
+C
+C output: PD(-6:6) x*f(x) parton distribution functions
+C (PDFLIB convention: d = PD(1), u = PD(2) )
+C
+C**********************************************************************
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
+ DIMENSION QQ(7)
+
+ Q2=SNGL(SCALE2)
+ Q1S=Q2
+ XX=SNGL(X)
+C QCD lambda for evolution
+ OWLAM = 0.23D0
+ OWLAM2=OWLAM**2
+C Q0**2 for evolution
+ Q02 = 2.D0
+C
+C
+C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
+C q(6)=x*charm, q(7)=x*gluon
+C
+ SB=0.
+ IF(Q2-Q02) 1,1,2
+ 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
+ 1 CONTINUE
+ IF(IPAR.EQ.2212) THEN
+* CALL PHO_CKMTPR(XX,SB,QQ
+ WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
+ CALL PHO_ABORT
+ ELSE
+ CALL PHO_CKMTPO(XX,SB,QQ)
+ ENDIF
+C
+ PD(-6) = 0.D0
+ PD(-5) = 0.D0
+ PD(-4) = DBLE(QQ(6))
+ PD(-3) = DBLE(QQ(3))
+ PD(-2) = DBLE(QQ(4))
+ PD(-1) = DBLE(QQ(5))
+ PD(0) = DBLE(QQ(7))
+ PD(1) = DBLE(QQ(2))
+ PD(2) = DBLE(QQ(1))
+ PD(3) = DBLE(QQ(3))
+ PD(4) = DBLE(QQ(6))
+ PD(5) = 0.D0
+ PD(6) = 0.D0
+ IF(IPAR.EQ.990) THEN
+ CDN = (PD(1)-PD(-1))/2.D0
+ CUP = (PD(2)-PD(-2))/2.D0
+ PD(-1) = PD(-1) + CDN
+ PD(-2) = PD(-2) + CUP
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ END
+
+*$ CREATE PHO_CKMTPO.FOR
+*COPY PHO_CKMTPO
+CDECK ID>, PHO_CKMTPO
+ SUBROUTINE PHO_CKMTPO(X,S,QQ)
+C**********************************************************************
+C
+C calculation partons in Pomeron
+C
+C**********************************************************************
+ SAVE
+
+ DIMENSION QQ(7)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.10/
+
+C RNG= -.5
+C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
+C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
+ DATA (DL(K),K= 1, 85) /
+ & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
+ & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
+ & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
+ & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
+ & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
+ & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
+ & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
+ & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
+ & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
+ & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
+ & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
+ & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
+ & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
+ & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
+ & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
+ & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
+ & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
+ DATA (DL(K),K= 86, 170) /
+ & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
+ & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
+ & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
+ & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
+ & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
+ & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
+ & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
+ & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
+ & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
+ & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
+ & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
+ & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
+ DATA (DL(K),K= 171, 255) /
+ & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
+ & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
+ & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
+ & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
+ & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
+ & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
+ & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
+ & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
+ & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
+ & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
+ & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
+ & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
+ & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
+ & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
+ & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
+ & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
+ & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
+ DATA (DL(K),K= 256, 340) /
+ & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
+ & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
+ & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
+ & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
+ & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
+ & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
+ & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
+ & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
+ & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
+ & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
+ & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
+ & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
+ DATA (DL(K),K= 341, 425) /
+ & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
+ & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
+ & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
+ & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
+ & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
+ & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
+ & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
+ & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
+ & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
+ & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
+ & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
+ & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
+ & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
+ & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
+ & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
+ & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
+ & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
+ DATA (DL(K),K= 426, 510) /
+ & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
+ & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
+ & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
+ & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
+ & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
+ & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
+ & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
+ & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
+ & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
+ & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
+ & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
+ & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
+ DATA (DL(K),K= 511, 595) /
+ & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
+ & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
+ & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
+ & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
+ & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
+ & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
+ & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
+ & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
+ & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
+ & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
+ & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
+ & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
+ & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
+ & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
+ & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
+ & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
+ & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
+ DATA (DL(K),K= 596, 680) /
+ & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
+ & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
+ & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
+ & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
+ & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
+ & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
+ & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
+ & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
+ & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
+ & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
+ & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
+ & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
+ DATA (DL(K),K= 681, 765) /
+ & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
+ & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
+ & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
+ & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
+ & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
+ & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
+ & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
+ & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
+ & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
+ & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
+ & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
+ & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
+ & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
+ & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
+ & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
+ & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
+ & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
+ DATA (DL(K),K= 766, 850) /
+ & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
+ & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
+ & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
+ & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
+ & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
+ & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
+ & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
+ & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
+ & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
+ & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
+ & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
+ & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
+ DATA (DL(K),K= 851, 935) /
+ & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
+ & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
+ & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
+ & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
+ & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
+ & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
+ & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
+ & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
+ & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
+ & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
+ & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
+ & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
+ & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
+ & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
+ & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
+ & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
+ & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
+ DATA (DL(K),K= 936, 1020) /
+ & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
+ & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
+ & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
+ & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
+ & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
+ & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
+ & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
+ & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
+ & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
+ & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
+ & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
+ & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
+ DATA (DL(K),K= 1021, 1105) /
+ & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
+ & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
+ & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
+ & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
+ & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
+ & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
+ & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
+ & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
+ & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
+ & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
+ & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
+ & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
+ & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
+ & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
+ & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
+ & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
+ & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
+ & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
+ & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
+ & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
+ & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
+ & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
+ & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
+ & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
+ & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
+ & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
+ & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
+ & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
+ & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
+ & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
+ & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
+ & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
+ & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
+ & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
+ & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
+ & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
+ & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
+ & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
+ & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
+ & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
+ & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
+ & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
+ & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
+ & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
+ & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
+ & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
+ & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
+ & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
+ & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
+ & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
+ & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
+ & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
+ & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
+ & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
+ & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
+ & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
+ & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
+ & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
+ & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
+ & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
+ & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
+ & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
+ & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
+ & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
+ & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
+ & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
+ & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
+ & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
+ DATA (DL(K),K= 1446, 1530) /
+ & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
+ & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
+ & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
+ & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
+ & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
+ & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
+ & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
+ & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
+ & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
+ & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
+ & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
+ & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
+ & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
+ & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
+ & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
+ & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
+ & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
+ DATA (DL(K),K= 1531, 1615) /
+ & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
+ & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
+ & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
+ & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
+ & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
+ & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
+ & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
+ & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
+ & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
+ & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
+ & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
+ & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
+ & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
+ & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
+ & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
+ & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
+ & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
+ & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
+ & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
+ & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
+ & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
+ & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
+ & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
+ & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
+ & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
+ & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
+ & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
+ & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
+ DATA (DL(K),K= 1701, 1785) /
+ & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
+ & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
+ & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
+ & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
+ & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
+ & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
+ & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
+ & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
+ & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
+ & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
+ & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
+ & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
+ DATA (DL(K),K= 1786, 1870) /
+ & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
+ & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
+ & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
+ & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
+ & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
+ & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
+ & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
+ & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
+ & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
+ & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
+ & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
+ & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
+ & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
+ & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
+ & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
+ & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
+ & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
+ DATA (DL(K),K= 1871, 1955) /
+ & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
+ & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
+ & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
+ & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
+ & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
+ & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
+ & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
+ & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
+ & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
+ & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
+ & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
+ & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
+ & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
+ & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
+ & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
+ & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
+ & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
+ & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
+ & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
+ & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
+ & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
+ & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
+ & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
+ & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
+ & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
+ & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
+ & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
+ & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
+ DATA (DL(K),K= 2041, 2125) /
+ & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
+ & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
+ & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
+ & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
+ & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
+ & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
+ & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
+ & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
+ & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
+ & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
+ & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
+ & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
+ & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
+ & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
+ & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
+ & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
+ & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
+ & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
+ & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
+ & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
+ & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
+ & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
+ & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
+ & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
+ & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
+ & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
+ & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
+ & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
+ DATA (DL(K),K= 2211, 2295) /
+ & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
+ & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
+ & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
+ & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
+ & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
+ & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
+ & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
+ & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
+ & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
+ & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
+ & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
+ & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
+ DATA (DL(K),K= 2296, 2380) /
+ & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
+ & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
+ & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
+ & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
+ & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
+ & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
+ & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
+ & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
+ & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
+ & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
+ & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
+ & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
+ & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
+ & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
+ & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
+ & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
+ & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2381, 2465) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
+ & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
+ & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
+ & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
+ & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
+ & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
+ & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
+ & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
+ & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
+ & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
+ & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
+ & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
+ & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
+ DATA (DL(K),K= 2466, 2550) /
+ & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
+ & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
+ & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
+ & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
+ & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
+ & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
+ & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
+ & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
+ & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
+ & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
+ & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
+ & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
+ & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
+ & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
+ & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2551, 2635) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
+ & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
+ & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
+ & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
+ & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
+ & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
+ & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
+ & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
+ & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
+ & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
+ & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
+ & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
+ & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
+ & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
+ & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
+ DATA (DL(K),K= 2636, 2720) /
+ & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
+ & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
+ & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
+ & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
+ & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
+ & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
+ & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
+ & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
+ & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
+ & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
+ & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
+ & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
+ & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
+ & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
+ & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
+ & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
+ & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
+ & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
+ & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
+ & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
+ & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
+ & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
+ & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
+ & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
+ & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
+ & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
+ & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
+ & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
+ & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
+ DATA (DL(K),K= 2806, 2890) /
+ & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
+ & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
+ & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
+ & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
+ & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
+ & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
+ & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
+ & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
+ & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
+ & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
+ & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
+ & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
+ DATA (DL(K),K= 2891, 2975) /
+ & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
+ & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
+ & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
+ & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
+ & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
+ & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
+ & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
+ & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
+ & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
+ & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
+ & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
+ & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
+ & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
+ & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
+ & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
+ & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
+ & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
+ DATA (DL(K),K= 2976, 3060) /
+ & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
+ & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
+ & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
+ & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
+ & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
+ & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
+ & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
+ & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
+ & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
+ & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
+ & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
+ & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
+ DATA (DL(K),K= 3061, 3145) /
+ & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
+ & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
+ & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
+ & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
+ & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
+ & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
+ & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
+ & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
+ & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
+ & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
+ & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
+ & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
+ & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
+ & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
+ & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
+ & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
+ & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
+ & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
+ & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
+ & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
+ & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
+ & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
+ & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
+ & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
+ & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
+ & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
+ & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
+ & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
+ DATA (DL(K),K= 3231, 3315) /
+ & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
+ & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
+ & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
+ & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
+ & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
+ & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
+ & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
+ & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
+ & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
+ & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
+ & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
+ & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
+ & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
+ & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
+ & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
+ & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
+ & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
+ DATA (DL(K),K= 3316, 3400) /
+ & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
+ & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
+ & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
+ & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
+ & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
+ & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
+ & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
+ & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
+ & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
+ & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
+ & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
+ & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
+ DATA (DL(K),K= 3401, 3485) /
+ & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
+ & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
+ & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
+ & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
+ & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
+ & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
+ & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
+ & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
+ & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
+ & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
+ & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
+ & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
+ & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
+ & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
+ & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
+ & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
+ & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
+ DATA (DL(K),K= 3486, 3570) /
+ & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
+ & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
+ & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
+ & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
+ & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
+ & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
+ & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
+ & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
+ & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
+ & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
+ & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
+ & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
+ DATA (DL(K),K= 3571, 3655) /
+ & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
+ & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
+ & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
+ & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
+ & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
+ & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
+ & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
+ & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
+ & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
+ & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
+ & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
+ & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
+ & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
+ & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
+ & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
+ & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
+ & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
+ DATA (DL(K),K= 3656, 3740) /
+ & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
+ & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
+ & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
+ & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
+ & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
+ & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
+ & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
+ & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
+ & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
+ & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
+ & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
+ & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
+ DATA (DL(K),K= 3741, 3825) /
+ & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
+ & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
+ & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
+ & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
+ & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
+ & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
+ & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
+ & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
+ & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
+ & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
+ & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
+ & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
+ & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
+ & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
+ & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
+ & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 3826, 3910) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
+ & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
+ & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
+ & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
+ & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
+ & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
+ & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
+ & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
+ & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
+ & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
+ & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
+ & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
+ & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
+ & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
+ DATA (DL(K),K= 3911, 3995) /
+ & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
+ & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
+ & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
+ & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
+ & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
+ & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
+ & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
+ & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
+ & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
+ & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
+ & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
+ & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
+ & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
+ & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+
+ DO 10 I=1,7
+ QQ(I) = 0.
+ 10 CONTINUE
+ IF(X.GT.0.9985) RETURN
+
+ IS = S/DELTA+1
+ IS = MIN(IS,19)
+ IS1 = IS+1
+ DO 20 I=1,7
+ IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
+ IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
+ DO 30 L=1,25
+ F1(L)=GF(I,IS,L)
+ F2(L)=GF(I,IS1,L)
+ 30 CONTINUE
+ S1=(IS-1)*DELTA
+ S2=S1+DELTA
+ A1 = PHO_CKMTFV(X,F1)
+ A2 = PHO_CKMTFV(X,F2)
+ QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
+ 19 CONTINUE
+ 20 CONTINUE
+
+ END
+
+*$ CREATE PHO_CKMTFV.FOR
+*COPY PHO_CKMTFV
+CDECK ID>, PHO_CKMTFV
+ REAL FUNCTION PHO_CKMTFV(X,FVL)
+C**********************************************************************
+C
+C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
+C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
+C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
+C IN MAIN ROUTINE.
+C
+C**********************************************************************
+ SAVE
+
+ DIMENSION FVL(25),XGRID(25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
+ *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
+
+ PHO_CKMTFV=0.
+ DO 1 I=1,NX
+ IF(X.LT.XGRID(I)) GO TO 2
+ 1 CONTINUE
+ 2 I=I-1
+ IF(I.EQ.0) THEN
+ I=I+1
+ ELSE IF(I.GT.23) THEN
+ I=23
+ ENDIF
+ J=I+1
+ K=J+1
+ AXI=LOG(XGRID(I))
+ BXI=LOG(1.-XGRID(I))
+ AXJ=LOG(XGRID(J))
+ BXJ=LOG(1.-XGRID(J))
+ AXK=LOG(XGRID(K))
+ BXK=LOG(1.-XGRID(K))
+ FI=LOG(ABS(FVL(I)) +1.E-15)
+ FJ=LOG(ABS(FVL(J)) +1.E-16)
+ FK=LOG(ABS(FVL(K)) +1.E-17)
+ DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
+ ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
+ $ BXI))/DET
+ ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
+ BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
+ IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
+ 1RETURN
+C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
+C WRITE(LO,2001) X,FVL
+C 2001 FORMAT(8E12.4)
+C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
+C ENDIF
+ PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
+
+ END
+
+*$ CREATE PHO_SASGAM.FOR
+*COPY PHO_SASGAM
+CDECK ID>, PHO_SASGAM
+C***********************************************************************
+C...SaSgam version 2 - parton distributions of the photon
+C...by Gerhard A. Schuler and Torbjorn Sjostrand
+C...For further information see Z. Phys. C68 (1995) 607
+C...and Phys. Lett. B376 (1996) 193.
+
+C...18 January 1996: original code.
+C...22 July 1996: calculation of BETA moved in SASBEH.
+
+C!!!Note that one further call parameter - IP2 - has been added
+C!!!to the SASGAM argument list compared with version 1.
+
+C...The user should only need to call the SASGAM routine,
+C...which in turn calls the auxiliary routines SASVMD, SASANO,
+C...SASBEH and SASDIR. The package is self-contained.
+
+C...One particular aspect of these parametrizations is that F2 for
+C...the photon is not obtained just as the charge-squared-weighted
+C...sum of quark distributions, but differ in the treatment of
+C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
+C...the kinematics range of heavy-flavour production, but the same
+C...kinematics is not relevant e.g. for jet production) and, for the
+C...'MSbar' fits, in the addition of a Cgamma term related to the
+C...separation of direct processes. Schematically:
+C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
+C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
+C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
+C...The J/psi and Upsilon states have not been included in the VMD sum,
+C...but low c and b masses in the other components should compensate
+C...for this in a duality sense.
+
+C...The calling sequence is the following:
+C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...with the following declaration statement:
+C DIMENSION XPDFGM(-6:6)
+C...and, optionally, further information in:
+C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+C &XPDIR(-6:6)
+C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
+C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
+C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
+C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
+C X : x value.
+C Q2 : Q2 value.
+C P2 : P2 value; should be = 0. for an on-shell photon.
+C IP2 : scheme used to evaluate off-shell anomalous component.
+C = 0 : recommended default, see = 7.
+C = 1 : dipole dampening by integration; very time-consuming.
+C = 2 : P_0^2 = max( Q_0^2, P^2 )
+C = 3 : P_0^2 = Q_0^2 + P^2.
+C = 4 : P_{eff} that preserves momentum sum.
+C = 5 : P_{int} that preserves momentum and average
+C evolution range.
+C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
+C XPFDGM : x times parton distribution functions of the photon,
+C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
+C 6 = t (always empty!), - for antiquarks (result is same).
+C...The breakdown by component is stored in the commonblock SASCOM,
+C with elements as above.
+C XPVMD : rho, omega, phi VMD part only of output.
+C XPANL : d, u, s anomalous part only of output.
+C XPANH : c, b anomalous part only of output.
+C XPBEH : c, b Bethe-Heitler part only of output.
+C XPDIR : Cgamma (direct contribution) part only of output.
+C...The above arrays do not distinguish valence and sea contributions,
+C...although this information is available internally. The additional
+C...commonblock SASVAL provides the valence part only of the above
+C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
+C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
+C...and therefore not given doubly. VXPDGM gives the sum of valence
+C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
+C...and so on, gives the sea part only.
+C***********************************************************************
+
+ SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...Purpose: to construct the F2 and parton distributions of the photon
+C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
+C...For F2, c and b are included by the Bethe-Heitler formula;
+C...in the 'MSbar' scheme additionally a Cgamma term is added.
+ SAVE
+ DIMENSION XPDFGM(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+**sr
+C SAVE /SASCOM/,/SASVAL/
+**
+
+C...Temporary array.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+C...Charm and bottom masses (low to compensate for J/psi etc.).
+ DATA PMC/1.3/, PMB/4.6/
+C...alpha_em and alpha_em/(2*pi).
+ DATA AEM/0.007297/, AEM2PI/0.0011614/
+C...Lambda value for 4 flavours.
+ DATA ALAM/0.20/
+C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
+ DATA FRACU/0.8/
+C...VMD couplings f_V**2/(4*pi).
+ DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
+C...Masses for rho (=omega) and phi.
+ DATA PMRHO/0.770/, PMPHI/1.020/
+C...Number of points in integration for IP2=1.
+ DATA NSTEP/100/
+
+C...Reset output.
+ F2GM=0.
+ DO 100 KFL=-6,6
+ XPDFGM(KFL)=0.
+ XPVMD(KFL)=0.
+ XPANL(KFL)=0.
+ XPANH(KFL)=0.
+ XPBEH(KFL)=0.
+ XPDIR(KFL)=0.
+ VXPVMD(KFL)=0.
+ VXPANL(KFL)=0.
+ VXPANH(KFL)=0.
+ VXPDGM(KFL)=0.
+ 100 CONTINUE
+
+C...Check that input sensible.
+ IF(ISET.LE.0.OR.ISET.GE.5) THEN
+ WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
+ WRITE(LO,*) ' ISET = ',ISET
+ STOP
+ ENDIF
+ IF(X.LE.0..OR.X.GT.1.) THEN
+ WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
+ WRITE(LO,*) ' X = ',X
+ STOP
+ ENDIF
+
+C...Set Q0 cut-off parameter as function of set used.
+ IF(ISET.LE.2) THEN
+ Q0=0.6
+ ELSE
+ Q0=2.
+ ENDIF
+ Q02=Q0**2
+
+C...Scale choice for off-shell photon; common factors.
+ Q2A=Q2
+ FACNOR=1.
+ IF(IP2.EQ.1) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ FACNOR=LOG(Q2/Q02)/NSTEP
+ ELSEIF(IP2.EQ.2) THEN
+ P2MX=MAX(P2,Q02)
+ ELSEIF(IP2.EQ.3) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ ELSEIF(IP2.EQ.4) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ ELSEIF(IP2.EQ.5) THEN
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
+ ELSEIF(IP2.EQ.6) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ ELSE
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ P2MXB=P2MX
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
+ ENDIF
+
+C...Call VMD parametrization for d quark and use to give rho, omega,
+C...phi. Note dipole dampening for off-shell photon.
+ CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ XFVAL=VXPGA(1)
+ XPGA(1)=XPGA(2)
+ XPGA(-1)=XPGA(-2)
+ FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
+ FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
+ DO 110 KFL=-5,5
+ XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
+ 110 CONTINUE
+ XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
+ XPVMD(3)=XPVMD(3)+FACS*XFVAL
+ XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
+ XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
+ VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(2)=FRACU*FACUD*XFVAL
+ VXPVMD(3)=FACS*XFVAL
+ VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(-2)=FRACU*FACUD*XFVAL
+ VXPVMD(-3)=FACS*XFVAL
+
+ IF(IP2.NE.1) THEN
+C...Anomalous parametrizations for different strategies
+C...for off-shell photons; except full integration.
+
+C...Call anomalous parametrization for d + u + s.
+ CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 120 KFL=-5,5
+ XPANL(KFL)=FACNOR*XPGA(KFL)
+ VXPANL(KFL)=FACNOR*VXPGA(KFL)
+ 120 CONTINUE
+
+C...Call anomalous parametrization for c and b.
+ CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 130 KFL=-5,5
+ XPANH(KFL)=FACNOR*XPGA(KFL)
+ VXPANH(KFL)=FACNOR*VXPGA(KFL)
+ 130 CONTINUE
+ CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 140 KFL=-5,5
+ XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
+ VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
+ 140 CONTINUE
+
+ ELSE
+C...Special option: loop over flavours and integrate over k2.
+ DO 170 KF=1,5
+ DO 160 ISTEP=1,NSTEP
+ Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
+ IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
+ & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
+ CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
+ FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
+ IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
+ IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
+ DO 150 KFL=-5,5
+ IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
+ IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
+ IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
+ IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ ENDIF
+
+C...Call Bethe-Heitler term expression for charm and bottom.
+ CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
+ XPBEH(4)=XPBH
+ XPBEH(-4)=XPBH
+ CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
+ XPBEH(5)=XPBH
+ XPBEH(-5)=XPBH
+
+C...For MSbar subtraction call C^gamma term expression for d, u, s.
+ IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
+ CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
+ DO 180 KFL=-5,5
+ XPDIR(KFL)=XPGA(KFL)
+ 180 CONTINUE
+ ENDIF
+
+C...Store result in output array.
+ DO 190 KFL=-5,5
+ CHSQ=1./9.
+ IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
+ XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
+ IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
+ XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
+ VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
+ 190 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+*$ CREATE PHO_SASVMD.FOR
+*COPY PHO_SASVMD
+CDECK ID>, PHO_SASVMD
+ SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the VMD parton distributions of a photon,
+C...evolved homogeneously from an initial scale P2 to Q2.
+C...Does not include dipole suppression factor.
+C...ISET is parton distribution set, see above;
+C...additionally ISET=0 is used for the evolution of an anomalous photon
+C...which branched at a scale P2 and then evolved homogeneously to Q2.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ SAVE
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAM3=ALAM*(PMC/ALAM)**(2./27.)
+ ALAM5=ALAM*(ALAM/PMB)**(2./23.)
+ P2EFF=MAX(P2,1.2*ALAM3**2)
+ IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Find s as sum of 3-, 4- and 5-flavour parts.
+ S=0.
+ IF(NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ IF(NFQ.EQ.3) Q2DIV=Q2EFF
+ S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
+ ENDIF
+ IF(NFP.LE.4.AND.NFQ.GE.4) THEN
+ P2DIV=P2EFF
+ IF(NFP.EQ.3) P2DIV=PMC**2
+ Q2DIV=Q2EFF
+ IF(NFQ.EQ.5) Q2DIV=PMB**2
+ S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
+ ENDIF
+ IF(NFQ.EQ.5) THEN
+ P2DIV=PMB**2
+ IF(NFP.EQ.5) P2DIV=P2EFF
+ S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
+ ENDIF
+
+C...Calculate frequent combinations of x and s.
+ X1=1.-X
+ XL=-LOG(X)
+ S2=S**2
+ S3=S**3
+ S4=S**4
+
+C...Evaluate homogeneous anomalous parton distributions below or
+C...above threshold.
+ IF(ISET.EQ.0) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X * 1.5 * (X**2+X1**2)
+ XGLU = 0.
+ XSEA = 0.
+ ELSE
+ XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
+ & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
+ & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
+ XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
+ & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
+ & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
+ XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
+ & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
+ & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+ ENDIF
+
+C...Evaluate set 1D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.1) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.294 * X**0.80 * X1**0.76
+ XGLU = 1.273 * X**0.40 * X1**1.76
+ XSEA = 0.100 * X1**3.76
+ ELSE
+ XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
+ & X1**(0.76+0.667*S) * XL**(2.*S)
+ XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
+ & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
+ & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
+ XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
+ & X**(-7.32*S2/(1.+10.3*S2)) *
+ & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
+ XSEA0 = 0.100 * X1**3.76
+ ENDIF
+
+C...Evaluate set 1M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.2) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 0.8477 * X**0.51 * X1**1.37
+ XGLU = 3.42 * X**0.255 * X1**2.37
+ XSEA = 0.
+ ELSE
+ XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
+ & * X1**1.37 * XL**(2.667*S)
+ XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
+ & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
+ & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
+ & X1**(2.37+3.*S)
+ XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
+ & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
+ & XL**(2.8*S)
+ XSEA0 = 0.
+ ENDIF
+
+C...Evaluate set 2D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.3) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X**0.46 * X1**0.64 + 0.76 * X
+ XGLU = 1.925 * X1**2
+ XSEA = 0.242 * X1**4
+ ELSE
+ XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
+ & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
+ & (0.76+0.4*S) * X * X1**(2.667*S)
+ XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
+ & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
+ & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
+ XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
+ & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
+ XSEA0 = 0.242 * X1**4
+ ENDIF
+
+C...Evaluate set 2M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.4) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
+ XGLU = 1.808 * X1**2
+ XSEA = 0.209 * X1**4
+ ELSE
+ XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
+ & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
+ & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
+ & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
+ XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
+ & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
+ & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
+ & XL**(10.9*S/(1.+2.5*S))
+ XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
+ & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
+ & X1**(4.+S) * XL**(0.45*S)
+ XSEA0 = 0.209 * X1**4
+ ENDIF
+ ENDIF
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XCHM=XSEA*(1.-(SCH/SLL)**2)
+ ELSE
+ XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
+ ENDIF
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XBOT=XSEA*(1.-(SBT/SLL)**2)
+ ELSE
+ XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
+ ENDIF
+ ENDIF
+
+C...Fill parton distributions.
+ XPGA(0)=XGLU
+ XPGA(1)=XSEA
+ XPGA(2)=XSEA
+ XPGA(3)=XSEA
+ XPGA(4)=XCHM
+ XPGA(5)=XBOT
+ XPGA(KFA)=XPGA(KFA)+XVAL
+ DO 110 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ 110 CONTINUE
+ VXPGA(KFA)=XVAL
+ VXPGA(-KFA)=XVAL
+
+ RETURN
+ END
+
+C*********************************************************************
+
+*$ CREATE PHO_SASANO.FOR
+*COPY PHO_SASANO
+CDECK ID>, PHO_SASANO
+ SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the parton distributions of the anomalous
+C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
+C...to Q2.
+C...KF=0 gives the sum over (up to) 5 flavours,
+C...KF<0 limits to flavours up to abs(KF),
+C...KF>0 is for flavour KF only.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
+ DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ IF(Q2.LE.P2) RETURN
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
+ ALAMSQ(4)=ALAM**2
+ ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
+ P2EFF=MAX(P2,1.2*ALAMSQ(3))
+ IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ XL=-LOG(X)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Define range of flavour loop.
+ IF(KF.EQ.0) THEN
+ KFLMN=1
+ KFLMX=5
+ ELSEIF(KF.LT.0) THEN
+ KFLMN=1
+ KFLMX=KFA
+ ELSE
+ KFLMN=KFA
+ KFLMX=KFA
+ ENDIF
+
+C...Loop over flavours the photon can branch into.
+ DO 110 KFL=KFLMN,KFLMX
+
+C...Light flavours: calculate t range and (approximate) s range.
+ IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.GT.NFP) THEN
+ Q2DIV=PMB**2
+ IF(NFQ.EQ.4) Q2DIV=PMC**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+ IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
+ & LOG(P2EFF/ALAMSQ(4)))
+ SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
+ & LOG(P2EFF/ALAMSQ(3)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
+ ENDIF
+
+C...u and s quark do not need a separate treatment when d has been done.
+ ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
+
+C...Charm: as above, but only include range above c threshold.
+ ELSEIF(KFL.EQ.4) THEN
+ IF(Q2.LE.PMC**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMC**2)
+ Q2EFF=MAX(Q2EFF,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
+ Q2DIV=PMB**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+
+C...Bottom: as above, but only include range above b threshold.
+ ELSEIF(KFL.EQ.5) THEN
+ IF(Q2.LE.PMB**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ ENDIF
+
+C...Evaluate flavour-dependent prefactor (charge^2 etc.).
+ CHSQ=1./9.
+ IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
+ FAC=AEM2PI*2.*CHSQ*TDIFF
+
+C...Evaluate parton distributions (normalized to unit momentum sum).
+ IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
+ XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
+ & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
+ & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
+ & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
+ XGLU= 2.*S/(1.+4.*S+7.*S**2) *
+ & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
+ & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
+ XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
+ & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
+ & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XCHM=XSEA*(1.-(SCH/SLL)**3)
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XBOT=XSEA*(1.-(SBT/SLL)**3)
+ ENDIF
+ ENDIF
+
+C...Add contribution of each valence flavour.
+ XPGA(0)=XPGA(0)+FAC*XGLU
+ XPGA(1)=XPGA(1)+FAC*XSEA
+ XPGA(2)=XPGA(2)+FAC*XSEA
+ XPGA(3)=XPGA(3)+FAC*XSEA
+ XPGA(4)=XPGA(4)+FAC*XCHM
+ XPGA(5)=XPGA(5)+FAC*XBOT
+ XPGA(KFL)=XPGA(KFL)+FAC*XVAL
+ VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
+ 110 CONTINUE
+ DO 120 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ VXPGA(-KFL)=VXPGA(KFL)
+ 120 CONTINUE
+
+ END
+
+C*********************************************************************
+
+*$ CREATE PHO_SASBEH.FOR
+*COPY PHO_SASBEH
+CDECK ID>, PHO_SASBEH
+ SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
+C...Purpose: to evaluate the Bethe-Heitler cross section for
+C...heavy flavour production.
+ SAVE
+ DATA AEM2PI/0.0011614/
+
+C...Reset output.
+ XPBH=0.
+ SIGBH=0.
+
+C...Check kinematics limits.
+ IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
+ W2=Q2*(1.-X)/X-P2
+ BETA2=1.-4.*PM2/W2
+ IF(BETA2.LT.1E-10) RETURN
+ BETA=SQRT(BETA2)
+ RMQ=4.*PM2/Q2
+
+C...Simple case: P2 = 0.
+ IF(P2.LT.1E-4) THEN
+ IF(BETA.LT.0.99) THEN
+ XBL=LOG((1.+BETA)/(1.-BETA))
+ ELSE
+ XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
+ ENDIF
+ SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
+
+C...Complicated case: P2 > 0, based on approximation of
+C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
+ ELSE
+ RPQ=1.-4.*X**2*P2/Q2
+ IF(RPQ.GT.1E-10) THEN
+ RPBE=SQRT(RPQ*BETA2)
+ IF(RPBE.LT.0.99) THEN
+ XBL=LOG((1.+RPBE)/(1.-RPBE))
+ XBI=2.*RPBE/(1.-RPBE**2)
+ ELSE
+ RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
+ XBL=LOG((1.+RPBE)**2/RPBESN)
+ XBI=2.*RPBE/RPBESN
+ ENDIF
+ SIGBH=BETA*(6.*X*(1.-X)-1.)+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
+ & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
+ ENDIF
+ ENDIF
+
+C...Multiply by charge-squared etc. to get parton distribution.
+ CHSQ=1./9.
+ IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
+ XPBH=3.*CHSQ*AEM2PI*X*SIGBH
+
+ END
+
+C*********************************************************************
+
+*$ CREATE PHO_SASDIR.FOR
+*COPY PHO_SASDIR
+CDECK ID>, PHO_SASDIR
+ SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
+C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
+C...as needed in MSbar parametrizations.
+ SAVE
+ DIMENSION XPGA(-6:6)
+ DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ 100 CONTINUE
+
+C...Evaluate common x-dependent expression.
+ XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
+ CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
+
+C...d, u, s part by simple charge factor.
+ XPGA(1)=(1./9.)*CGAM
+ XPGA(2)=(4./9.)*CGAM
+ XPGA(3)=(1./9.)*CGAM
+
+C...Also fill for antiquarks.
+ DO 110 KF=1,5
+ XPGA(-KF)=XPGA(KF)
+ 110 CONTINUE
+
+ END
+
+*$ CREATE PHO_PHGAL.FOR
+*COPY PHO_PHGAL
+CDECK ID>, PHO_PHGAL
+ SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
+C***********************************************************************
+C
+C photon parton densities with built-in momentum sum rule and
+C Regge-based low-x behaviour
+C
+C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
+C e-Print Archive: hep-ph/9711355
+C
+C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
+ DOUBLE PRECISION
+ & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
+ & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
+
+ DIMENSION NA(NARG)
+
+ DATA ZEROD/0.D0/
+
+C...100 x values; in (D-4,.77) log spaced (78 points)
+C... in (.78,.995) lineary spaced (22 points)
+ DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
+ DATA XT/
+ &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
+ &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
+ &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
+ &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
+ &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
+ &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
+ &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
+ &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
+ &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
+ &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
+ &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
+ &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
+ &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
+ &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
+ &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
+ &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
+ &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
+
+C...place for DATA blocks
+ DATA (XPV(I,1,0),I=1,100)/
+ &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
+ &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
+ &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
+ &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
+ &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
+ &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
+ &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
+ &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
+ &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
+ &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
+ &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
+ &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
+ &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
+ &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
+ &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
+ &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
+ &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
+ DATA (XPV(I,1,1),I=1,100)/
+ &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
+ &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
+ &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
+ &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
+ &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
+ &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
+ &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
+ &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
+ &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
+ &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
+ &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
+ &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
+ &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
+ &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
+ &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
+ &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
+ &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
+ DATA (XPV(I,1,2),I=1,100)/
+ &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
+ &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
+ &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
+ &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
+ &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
+ &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
+ &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
+ &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
+ &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
+ &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
+ &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
+ &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
+ &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
+ &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
+ &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
+ &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
+ &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
+ DATA (XPV(I,1,3),I=1,100)/
+ &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
+ &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
+ &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
+ &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
+ &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
+ &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
+ &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
+ &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
+ &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
+ &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
+ &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
+ &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
+ &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
+ &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
+ &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
+ &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
+ &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
+ DATA (XPV(I,1,4),I=1,100)/
+ &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
+ &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
+ &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
+ &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
+ &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
+ &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
+ &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
+ &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
+ &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
+ &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
+ &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
+ &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
+ &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
+ &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
+ &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
+ &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
+ &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
+ DATA (XPV(I,2,0),I=1,100)/
+ &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
+ &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
+ &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
+ &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
+ &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
+ &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
+ &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
+ &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
+ &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
+ &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
+ &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
+ &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
+ &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
+ &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
+ &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
+ &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
+ &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
+ DATA (XPV(I,2,1),I=1,100)/
+ &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
+ &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
+ &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
+ &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
+ &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
+ &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
+ &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
+ &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
+ &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
+ &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
+ &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
+ &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
+ &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
+ &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
+ &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
+ &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
+ &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
+ DATA (XPV(I,2,2),I=1,100)/
+ &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
+ &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
+ &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
+ &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
+ &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
+ &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
+ &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
+ &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
+ &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
+ &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
+ &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
+ &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
+ &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
+ &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
+ &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
+ &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
+ &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
+ DATA (XPV(I,2,3),I=1,100)/
+ &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
+ &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
+ &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
+ &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
+ &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
+ &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
+ &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
+ &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
+ &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
+ &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
+ &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
+ &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
+ &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
+ &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
+ &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
+ &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
+ &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
+ DATA (XPV(I,2,4),I=1,100)/
+ &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
+ &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
+ &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
+ &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
+ &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
+ &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
+ &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
+ &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
+ &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
+ &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
+ &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
+ &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
+ &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
+ &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
+ &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
+ &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
+ &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
+ DATA (XPV(I,3,0),I=1,100)/
+ &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
+ &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
+ &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
+ &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
+ &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
+ &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
+ &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
+ &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
+ &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
+ &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
+ &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
+ &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
+ &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
+ &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
+ &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
+ &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
+ &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
+ DATA (XPV(I,3,1),I=1,100)/
+ &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
+ &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
+ &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
+ &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
+ &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
+ &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
+ &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
+ &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
+ &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
+ &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
+ &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
+ &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
+ &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
+ &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
+ &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
+ &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
+ &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
+ DATA (XPV(I,3,2),I=1,100)/
+ &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
+ &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
+ &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
+ &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
+ &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
+ &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
+ &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
+ &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
+ &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
+ &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
+ &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
+ &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
+ &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
+ &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
+ &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
+ &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
+ &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
+ DATA (XPV(I,3,3),I=1,100)/
+ &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
+ &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
+ &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
+ &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
+ &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
+ &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
+ &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
+ &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
+ &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
+ &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
+ &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
+ &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
+ &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
+ &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
+ &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
+ &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
+ &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
+ DATA (XPV(I,3,4),I=1,100)/
+ &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
+ &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
+ &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
+ &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
+ &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
+ &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
+ &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
+ &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
+ &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
+ &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
+ &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
+ &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
+ &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
+ &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
+ &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
+ &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
+ &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
+ DATA (XPV(I,4,0),I=1,100)/
+ &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
+ &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
+ &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
+ &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
+ &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
+ &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
+ &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
+ &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
+ &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
+ &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
+ &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
+ &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
+ &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
+ &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
+ &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
+ &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
+ &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
+ DATA (XPV(I,4,1),I=1,100)/
+ &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
+ &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
+ &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
+ &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
+ &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
+ &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
+ &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
+ &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
+ &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
+ &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
+ &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
+ &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
+ &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
+ &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
+ &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
+ &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
+ &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
+ DATA (XPV(I,4,2),I=1,100)/
+ &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
+ &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
+ &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
+ &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
+ &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
+ &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
+ &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
+ &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
+ &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
+ &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
+ &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
+ &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
+ &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
+ &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
+ &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
+ &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
+ &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
+ DATA (XPV(I,4,3),I=1,100)/
+ &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
+ &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
+ &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
+ &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
+ &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
+ &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
+ &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
+ &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
+ &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
+ &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
+ &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
+ &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
+ &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
+ &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
+ &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
+ &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
+ &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
+ DATA (XPV(I,4,4),I=1,100)/
+ &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
+ &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
+ &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
+ &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
+ &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
+ &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
+ &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
+ &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
+ &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
+ &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
+ &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
+ &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
+ &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
+ &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
+ &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
+ &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
+ &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
+ DATA (XPV(I,5,0),I=1,100)/
+ &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
+ &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
+ &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
+ &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
+ &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
+ &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
+ &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
+ &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
+ &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
+ &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
+ &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
+ &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
+ &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
+ &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
+ &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
+ &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
+ &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
+ DATA (XPV(I,5,1),I=1,100)/
+ &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
+ &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
+ &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
+ &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
+ &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
+ &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
+ &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
+ &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
+ &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
+ &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
+ &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
+ &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
+ &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
+ &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
+ &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
+ &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
+ &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
+ DATA (XPV(I,5,2),I=1,100)/
+ &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
+ &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
+ &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
+ &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
+ &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
+ &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
+ &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
+ &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
+ &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
+ &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
+ &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
+ &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
+ &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
+ &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
+ &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
+ &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
+ &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
+ DATA (XPV(I,5,3),I=1,100)/
+ &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
+ &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
+ &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
+ &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
+ &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
+ &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
+ &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
+ &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
+ &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
+ &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
+ &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
+ &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
+ &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
+ &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
+ &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
+ &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
+ &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
+ DATA (XPV(I,5,4),I=1,100)/
+ &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
+ &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
+ &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
+ &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
+ &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
+ &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
+ &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
+ &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
+ &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
+ &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
+ &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
+ &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
+ &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
+ &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
+ &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
+ &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
+ &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
+ DATA (XPV(I,6,0),I=1,100)/
+ &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
+ &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
+ &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
+ &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
+ &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
+ &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
+ &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
+ &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
+ &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
+ &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
+ &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
+ &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
+ &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
+ &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
+ &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
+ &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
+ &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
+ DATA (XPV(I,6,1),I=1,100)/
+ &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
+ &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
+ &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
+ &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
+ &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
+ &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
+ &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
+ &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
+ &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
+ &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
+ &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
+ &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
+ &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
+ &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
+ &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
+ &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
+ &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
+ DATA (XPV(I,6,2),I=1,100)/
+ &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
+ &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
+ &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
+ &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
+ &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
+ &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
+ &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
+ &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
+ &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
+ &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
+ &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
+ &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
+ &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
+ &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
+ &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
+ &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
+ &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
+ DATA (XPV(I,6,3),I=1,100)/
+ &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
+ &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
+ &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
+ &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
+ &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
+ &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
+ &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
+ &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
+ &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
+ &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
+ &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
+ &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
+ &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
+ &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
+ &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
+ &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
+ &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
+ DATA (XPV(I,6,4),I=1,100)/
+ &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
+ &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
+ &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
+ &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
+ &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
+ &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
+ &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
+ &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
+ &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
+ &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
+ &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
+ &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
+ &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
+ &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
+ &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
+ &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
+ &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
+ DATA (XPV(I,7,0),I=1,100)/
+ &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
+ &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
+ &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
+ &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
+ &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
+ &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
+ &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
+ &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
+ &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
+ &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
+ &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
+ &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
+ &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
+ &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
+ &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
+ &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
+ &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
+ DATA (XPV(I,7,1),I=1,100)/
+ &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
+ &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
+ &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
+ &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
+ &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
+ &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
+ &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
+ &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
+ &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
+ &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
+ &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
+ &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
+ &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
+ &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
+ &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
+ &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
+ &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
+ DATA (XPV(I,7,2),I=1,100)/
+ &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
+ &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
+ &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
+ &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
+ &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
+ &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
+ &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
+ &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
+ &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
+ &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
+ &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
+ &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
+ &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
+ &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
+ &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
+ &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
+ &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
+ DATA (XPV(I,7,3),I=1,100)/
+ &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
+ &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
+ &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
+ &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
+ &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
+ &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
+ &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
+ &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
+ &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
+ &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
+ &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
+ &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
+ &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
+ &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
+ &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
+ &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
+ &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
+ DATA (XPV(I,7,4),I=1,100)/
+ &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
+ &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
+ &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
+ &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
+ &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
+ &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
+ &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
+ &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
+ &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
+ &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
+ &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
+ &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
+ &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
+ &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
+ &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
+ &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
+ &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
+
+C..fetching pdfs
+ DO 5 IP=-6,6
+ XPDF(IP)=ZEROD
+ 5 CONTINUE
+ DO 2 I=1,IX
+ ENT(I)=LOG10(XT(I))
+ 2 CONTINUE
+ NA(1)=IX
+ NA(2)=IQ
+ DO 3 I=1,IQ
+ ENT(IX+I)=LOG10(Q2T(I))
+ 3 CONTINUE
+ ARG(1)=LOG10(X)
+ ARG(2)=LOG10(Q2)
+C..various flavours (u-->2,d-->1)
+ XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
+ XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
+ XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
+ XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
+ XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
+ DO 21 JF=1,4
+ XPDF(-JF)=XPDF(JF)
+ 21 CONTINUE
+
+ END
+
+*$ CREATE PHO_DBFINT.FOR
+*COPY PHO_DBFINT
+CDECK ID>, PHO_DBFINT
+ DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
+C***********************************************************************
+C
+C routine based on CERN library E104
+C
+C multi-dimensional interpolation routine, needed for PHOJET
+C internal cross section tables and several PDF sets (GRV98 and AGL)
+C
+C changed to avoid recursive function calls (R.Engel, 09/98)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ INTEGER NA(NARG), INDEX(32)
+ DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
+
+ DATA ZEROD/0.D0/
+ DATA ONED/1.D0/
+
+ DBFINT = ZEROD
+ PHO_DBFINT = ZEROD
+ IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
+
+ LMAX = 0
+ ISTEP = 1
+ KNOTS = 1
+ INDEX(1) = 1
+ WEIGHT(1) = ONED
+ DO 100 N = 1, NARG
+ X = ARG(N)
+ NDIM = NA(N)
+ LOCA = LMAX
+ LMIN = LMAX + 1
+ LMAX = LMAX + NDIM
+ IF(NDIM .GT. 2) GOTO 10
+ IF(NDIM .EQ. 1) GOTO 100
+ H = X - ENT(LMIN)
+ IF(H .EQ. ZEROD) GOTO 90
+ ISHIFT = ISTEP
+ IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
+ ISHIFT = 0
+ ETA = H / (ENT(LMIN+1) - ENT(LMIN))
+ GOTO 30
+ 10 LOCB = LMAX + 1
+ 11 LOCC = (LOCA+LOCB) / 2
+ IF(X-ENT(LOCC)) 12, 20, 13
+ 12 LOCB = LOCC
+ GOTO 14
+ 13 LOCA = LOCC
+ 14 IF(LOCB-LOCA .GT. 1) GOTO 11
+ LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
+ ISHIFT = (LOCA - LMIN) * ISTEP
+ ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
+ GOTO 30
+ 20 ISHIFT = (LOCC - LMIN) * ISTEP
+ 21 DO 22 K = 1, KNOTS
+ INDEX(K) = INDEX(K) + ISHIFT
+ 22 CONTINUE
+ GOTO 90
+ 30 DO 31 K = 1, KNOTS
+ INDEX(K) = INDEX(K) + ISHIFT
+ INDEX(K+KNOTS) = INDEX(K) + ISTEP
+ WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
+ WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
+ 31 CONTINUE
+ KNOTS = 2*KNOTS
+ 90 ISTEP = ISTEP * NDIM
+ 100 CONTINUE
+ DO 200 K = 1, KNOTS
+ I = INDEX(K)
+ DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
+ 200 CONTINUE
+
+ PHO_DBFINT = DBFINT
+
+ END
+
+*$ CREATE PHVAL.FOR
+*COPY PHVAL
+CDECK ID>, PHVAL
+ SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
+C**********************************************************************
+C
+C dummy subroutine, remove to link PHOLIB
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DIMENSION PD(-6:6)
+ END