*$ 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(8000,2),BRAT(8000),KFDP(8000,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. (IT.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 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, & NCP,NCT * 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 NCP = 0 NCT = 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 DO 8 I=1, IP NCP = NCP+JSSH(I) * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP 8 CONTINUE DO 9 I=1, IT NCT = NCT+JTSH(I) * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT 9 CONTINUE 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_lab0)-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, & NCP,NCT * 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(8000,2),BRAT(8000),KFDP(8000,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(8000,2),BRAT(8000),KFDP(8000,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, & NCP,NCT * 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, & NCP,NCT * 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 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 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 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) INTEGER*4 LL, L, LOV 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