* *=== dpmini ===========================================================* * SUBROUTINE DPMINI (LESDPM,LOUDPM,IFDPM,PINP,IDPMVR,IDPMHK,IDPMFS) * *----------------------------------------------------------------------* * * * Version September 2001 by Stefan Roesler * * * * Last change 10-Nov-15 Alfredo Ferrari * * * * This subroutine is part of the FLUKA interface to DPMJET 3. * * new version (labelled 3.10 for convenience) after A.Fedynitch * * work * * Initialization of DPMJET 3 event generation. * * * * * * argument list (FLUKA control card: codewd = dpmjet) * * * * LESDPM dpmjet input follows at the bottom of Fluka input * * file and a second start card is required in this * * case * * LOUDPM logical unit number for dpmjet output * * IFDPM this flag indicates if (and at what level?) we * * expect dpmjet output * * for dpmjet-3 just on/off * * * PINP initial FLUKA beam momentum to indicate maximum * * available energy in the considered system * * IDPMVR output flag indicating service is rendered by * * dpmjet-3 * * IDPMHK carry over the dpmet(2/3) event common block size * * to enable important cross check since we have in * * principle 3 actual copies of it * * IDPMFS string fusion flag * * * *----------------------------------------------------------------------* * c IMPLICIT DOUBLE PRECISION (A-H,O-Z) c SAVE IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER ( KALGNM = 2 ) PARAMETER ( KALCH8 = 1 ) PARAMETER ( I2ALGN = 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 ( EXCSSV = +35.23192357547063 D+00 ) PARAMETER ( ENGLGB = -35.23192357547063 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 ( RHFLMN = 1.0D-10 ) REAL ZERSNG PARAMETER ( ZERSNG = 0.E+00 ) 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 ( ELEVEN = 11.D+00 ) PARAMETER ( TWELVE = 12.D+00 ) PARAMETER ( FIFTEN = 15.D+00 ) PARAMETER ( SIXTEN = 16.D+00 ) PARAMETER ( HLFHLF = 0.5D+00 ) PARAMETER ( ONETHI = ONEONE / THRTHR ) PARAMETER ( ONEFOU = ONEONE / FOUFOU ) PARAMETER ( ONEFIV = ONEONE / FIVFIV ) PARAMETER ( ONESIX = ONEONE / SIXSIX ) PARAMETER ( ONESEV = ONEONE / SEVSEV ) PARAMETER ( ONEEIG = ONEONE / EIGEIG ) PARAMETER ( TWOTHI = TWOTWO / THRTHR ) PARAMETER ( THRFOU = THRTHR / FOUFOU ) PARAMETER ( THRTWO = THRTHR / TWOTWO ) PARAMETER ( FOUTHR = FOUFOU / THRTHR ) PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) PARAMETER ( R3TOVL = FOUFOU * PIPIPI / THRTHR ) PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) PARAMETER ( SQRTPI = 1.772453850905516027298167483341D+00 ) PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) PARAMETER ( S2FWHM = 2.354820045030949382023138652919D+00 ) PARAMETER ( TWOLOG = 0.693147180559945309417232121458D+00 ) PARAMETER ( TWO2O3 = 1.587401051968199474751705639272D+00 ) PARAMETER ( TENLOG = 2.302585092994045684017991454684D+00 ) PARAMETER ( ATNFOU = 1.3258176636680326D+00 ) PARAMETER ( ATNSIX = 1.4056476493802699D+00 ) PARAMETER ( CLIGHT = 2.99792458 D+10 ) PARAMETER ( AVOGAD = 6.0221367 D+23 ) PARAMETER ( BOLTZM = 1.380658 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 ( AMPRMU = 1.007276470 D+00 ) PARAMETER ( AMNEMU = 1.008664904 D+00 ) PARAMETER ( EPSIL0 = 8.854187817 D-12 ) 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 ( AMPRTN = 0.93827231 D+00 ) PARAMETER ( AMNTRN = 0.93956563 D+00 ) PARAMETER ( AMDEUT = 1.87561339 D+00 ) PARAMETER ( AMALPH = 3.72738025692891 D+00 ) PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 & * 1.D-09 ) PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) PARAMETER ( ALAMB0 = TWOTWO * PIPIPI * RCLSEL / ALPFSC ) PARAMETER ( BLTZMN = 8.617385 D-14 ) PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) PARAMETER ( GFOHB3 = 1.16639 D-05 ) PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) PARAMETER ( SIN2TW = 0.2319 D+00 ) PARAMETER ( PRMGNM = 2.792847386 D+00 ) PARAMETER ( ANMGNM =-1.91304275 D+00 ) PARAMETER ( REARTH = 6.378140 D+08 ) PARAMETER ( AUASTU = 1.4959787066 D+13 ) PARAMETER ( GEVMEV = 1.0 D+03 ) PARAMETER ( EV2GEV = 1.0 D-09 ) PARAMETER ( GEV2EV = 1.0 D+09 ) PARAMETER ( EMVGEV = 1.0 D-03 ) PARAMETER ( CMQ2MB = 1.0 D+27 ) PARAMETER ( FMB2BA = 1.0 D-03 ) PARAMETER ( BAR2MB = 1.0 D+03 ) PARAMETER ( FMB2FS = 1.0 D-01 ) PARAMETER ( FMS2MB = 1.0 D+01 ) PARAMETER ( BA2CMQ = 1.0 D-24 ) PARAMETER ( CMQ2BA = 1.0 D+24 ) PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) PARAMETER ( GEVOMG = CLIGHT * 1.D+13 / PLABRC ) PARAMETER ( S0THMS = EIGEIG / THRTHR * PIPIPI * RCLSEL * RCLSEL & * CMQ2MB ) PARAMETER ( FERTHO = 14.33 D-09 ) PARAMETER ( EXPEBN = 2.39 D+00 ) PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) PARAMETER ( AMEMEV = GEVMEV * AMELCT ) PARAMETER ( T12INF = 1.D+30 ) PARAMETER ( T12ZER = 1.D-15 ) LOGICAL LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS, LUSRIN, & LUSRGL, LNMGEO, LNMINP, LFRFMT, LDMPCR LOGICAL LFDRTR COMMON / GLOBAL / LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS, LUSRIN, & LUSRGL, LNMGEO, LNMINP, LFRFMT, LDMPCR, & LFDRTR, & KFLGEO, KFLDNR COMMON / GLOBCH / CRVRFL CHARACTER*8 CRVRFL SAVE / GLOBAL /, / GLOBCH / PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) PARAMETER ( LUNIN = 5 ) PARAMETER ( LUNOUT = 11 ) PARAMETER ( LUNERR = 15 ) PARAMETER ( LUNBER = 14 ) PARAMETER ( LUNECH = 8 ) PARAMETER ( LUNFLU = 13 ) PARAMETER ( LUNGEO = 16 ) PARAMETER ( LUNPMF = 12 ) PARAMETER ( LUNRAN = 2 ) PARAMETER ( LUNXSC = 9 ) PARAMETER ( LUNDET = 17 ) PARAMETER ( LUNRAY = 10 ) PARAMETER ( LUNRDB = 1 ) PARAMETER ( LUNRD2 = 18 ) PARAMETER ( LUNDPM = 19 ) PARAMETER ( LUNPGO = 7 ) PARAMETER ( LUNPGS = 4 ) PARAMETER ( LUNSCR = 3 ) LOGICAL LBEAMC, LPPERP, LPFRAC, LDPGSS, LDVGSS, LDXGSS, LDYGSS, & LBAXIS, LFLOOD, LVLCAR, LVLCYL, LVLSPH, LSOURC, LRDBEA, & LNUFIN COMMON / BEAMCM / PBEAM , DPBEAM, PBMMAX, DIVBM , XSPOT , YSPOT , & XBEAM , YBEAM , ZBEAM , UBEAM , VBEAM , WBEAM , & UBMPOL, VBMPOL, WBMPOL, POLFRA, BEAWEI, & BMAXIS (3,3) , RFLOOD, RVLMIN, RVLMAX, DXVLMN, & DXVLMX, DYVLMN, DYVLMX, DZVLMN, DZVLMX, & IJBEAM, IJHION, NUCDBM, ISOURC, & LDPGSS, LDVGSS, LDXGSS, LDYGSS, LBEAMC, LPPERP, & LPFRAC, LBAXIS, LFLOOD, LVLCAR, LVLCYL, LVLSPH, & LSOURC, LRDBEA, LNUFIN SAVE / BEAMCM / COMMON / IOIOCM / EKNION, ETNION, PLNION, EEXION, T12ION, & MATPRJ (MXXMDF), NMATPR, IPROA , IPROZ , IPROM SAVE / IOIOCM / * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * event flag COMMON /DTEVNO/ NEVENT,ICASCA * Glauber formalism: flags and parameters for statistics LOGICAL LPROD CHARACTER*8 CGLB COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD * 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, & IFUSION,IFLOW * INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ * histogram indices for Fluka-interface related statistics * CHARACTER*72 HEADER DIMENSION XDUMB(40) COMMON /DTFLHX/ IHMAPR,IHMATA,IHIJPR,IHENUC,IHEHAD,IDPMEV COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI SAVE * * Redirect Dpmjet and Pythia output and turn on/off output * IDPMHK = NMXHKK IDPMVR = 310 LPRI = IFDPM LOUT = LOUDPM MSTU(11) = LOUDPM * * Flag for special settings needed to run the code as event * generator in Fluka (do not change !) * ITRSPT = 1 IEMUL = 0 IFUSION= IDPMFS EPN = PINP !---> should we * 1.5 NPMASS = IPROA ! NPCHAR = IPROZ !---> last two are taken out of FLUKA common * * Special settings if no Dpmjet input follows the Fluka input * IF (LESDPM .EQ. 0) THEN NINP = -1 ELSE NINP = 0 END IF * * Initialization of Dpmjet * IGLAUB= 0 CALL DT_INIT(NINP,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) CALL DT_STATIS(1) c CALL DT_DTUINI(NINP,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IEMU) NEVENT = 0 * IF (LPRI .LT. 3) RETURN * * Initialization of histograms * IDPMEV = 0 * mass number of projectile and target nuclei XLIM1 = 0.5D0 XLIM2 = 200.5D0 XLIM3 = 0d0 IBIN = INT(XLIM2-XLIM1) CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHMAPR) CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHMATA) * index of projectile hadrons CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHIJPR) * energy of projectile nuclei and hadrons XLIM1 = 5.0D0 XLIM2 = PBEAM c write(0,*) ' -pbeam-',pbeam XLIM3 = 0.D0 IBIN = -200 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHENUC) CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHEHAD) * RETURN *=== End of subroutine Dpmini =========================================* END * *=== Dpmout ===========================================================* * SUBROUTINE DPMOUT(IEVE) *----------------------------------------------------------------------* * Version March 2004 * * Last change * * * * This subroutine is part of the FLUKA interface to DPMJET 3. * * Printout of DPMJET 3 event generation statistics. * * * *----------------------------------------------------------------------* * histogram indices for Fluka-interface related statistics CHARACTER*72 HEADER COMMON /DTFLHX/ IHMAPR,IHMATA,IHIJPR,IHENUC,IHEHAD,IDPMEV COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) SAVE IF (LPRI .LT. 3 .OR. ICREQU .LT. 1) RETURN IF (IEVE.EQ.5) CALL DT_DTUOUT * * Write histograms with interaction parameter distributions * CALL DT_EVTHIS(IDUM) WRITE(LOUT,*) ' DPMOUT: Normalization factor = ',IDPMEV HEADER = ' A_projectile' CALL DT_OUTHGR(IHMAPR,0,0,0,0,0,HEADER,0,IDPMEV,1D+00,0,0,-1) HEADER = ' A_target' CALL DT_OUTHGR(IHMATA,0,0,0,0,0,HEADER,0,IDPMEV,1D+00,0,0,-1) HEADER = ' Id_projectile' CALL DT_OUTHGR(IHIJPR,0,0,0,0,0,HEADER,0,IDPMEV,1D+00,0,0,-1) HEADER = ' dN/dE (nuclei)' CALL DT_OUTHGR(IHENUC,0,0,0,0,0,HEADER,0,IDPMEV,1D+00,0,1,-1) HEADER = ' dN/dE (hadrons)' CALL DT_OUTHGR(IHEHAD,0,0,0,0,0,HEADER,0,IDPMEV,1D+00,0,1,-1) * RETURN *=== Dpmout ===========================================================* END * *=== Dpmrun ===========================================================* * SUBROUTINE DPMRUN(ELAB,IJDPM,IAP,IZP,IAT,IZT,LDPMRJ) * *----------------------------------------------------------------------* * * * Version September 2001 by Stefan Roesler * * Last change on 05-nov-01 by Stefan Roesler * * * * This subroutine is part of the FLUKA interface to DPMJET 3. * * Call to DPMJET 3 for event generation. * * * *----------------------------------------------------------------------* PARAMETER ( LUNIN = 5 ) PARAMETER ( LUNOUT = 11 ) PARAMETER ( LUNERR = 15 ) PARAMETER ( LUNBER = 14 ) PARAMETER ( LUNECH = 8 ) PARAMETER ( LUNFLU = 13 ) PARAMETER ( LUNGEO = 16 ) PARAMETER ( LUNPMF = 12 ) PARAMETER ( LUNRAN = 2 ) PARAMETER ( LUNXSC = 9 ) PARAMETER ( LUNDET = 17 ) PARAMETER ( LUNRAY = 10 ) PARAMETER ( LUNRDB = 1 ) PARAMETER ( LUNRD2 = 18 ) PARAMETER ( LUNDPM = 19 ) PARAMETER ( LUNPGO = 7 ) PARAMETER ( LUNPGS = 4 ) PARAMETER ( LUNSCR = 3 ) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * event flag COMMON /DTEVNO/ NEVENT,ICASCA * histogram indices for Fluka-interface related statistics COMMON /DTFLHX/ IHMAPR,IHMATA,IHIJPR,IHENUC,IHEHAD,IDPMEV COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LDPMRJ PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) IDP= IJDPM if ( IDP .LT. 0 ) IDP= 1 C WRITE(6,*)' DPMRUN(ELAB,IJDPM,IAP,IZP,IAT,IZT,LDPMRJ)', C *ELAB,IJDPM,IAP,IZP,IAT,IZT,LDPMRJ * patch for photons: assume pi0 instead (should be obsolete) IF ( IDP .EQ. 7 ) IDP = 23 IF ( IDP .EQ. 26 ) IDP = 23 * patch for hadrons which cannot (yet) be handled by Dpmjet: IF ( IDP .GT. 26 ) THEN * for virtual vector mesons assume pi0 (as in eventv) IF ( IJDPM .EQ. 30 ) THEN IDP = 23 ELSE * otherwise assume pi instead WRITE(LUNDPM,*) & ' EVENTD: Particle cannot be handled by Dpmjet ', & IJDPM,IDP IDP = 23 ENDIF ENDIF * write(0,*) ' -x-> ',IJDPM,iap,izp,iat,izt,ELAB * write(0,*) ' ----> eventd() ',IJDPM,IJDPM,' - ',IAP,IAT,ELAB KKMAT = -2 NEVENT = NEVENT + 1 CALL DT_KKINC(IAP,IZP,IAT,IZT,IDP,ELAB,KKMAT,IREJ) LDPMRJ = IREJ .NE. 0 * if (lpri.gt.5) then * write(0,*) ' ----> eventd() ',LDPMRJ,NHKK * DO I = 1, NHKK * IF ( ISTHKK(I) .EQ. 1000 ) ISTHKK(I) = 1001 * if (ISTHKK(i).eq.1001.or.ISTHKK(i).eq.1) then * write(0,'(2I4,I6,4I4,5E13.5,2I3,I2,I4,a5)') i,ISTHKK(i), * * IDHKK(i),JMOHKK(1,i),JMOHKK(2,i),JDAHKK(1,i),JDAHKK(2,i), * * (PHKK(LL,i),LL=1,5),IDRES(i),IDXRES(i),NOBAM(i),IDBAM(i), * . ' --o-' * if (i.eq.nhkk) write(0,*) ' ------- <<-o-<< ----' * endif * enddo * endif IF (LPRI .LT. 3) RETURN * * Internal statistics and call to usrhis * CALL PHO_PHIST(2000,DUM) * * Fill histograms with parameters of this interaction * IDPMEV = IDPMEV + 1 IF ( IAP .GT. 1 ) THEN RIAP = DBLE(IAP) CALL DT_FILHGR(RIAP,1d0,IHMAPR,IDPMEV) CALL DT_FILHGR(ELAB,1d0,IHENUC,IDPMEV) ELSE RIDP = DBLE(IDP) CALL DT_FILHGR(RIDP,1d0,IHIJPR,IDPMEV) CALL DT_FILHGR(ELAB,1d0,IHEHAD,IDPMEV) ENDIF RIAT = DBLE(IAT) CALL DT_FILHGR(RIAT,1d0,IHMATA,IDPMEV) RETURN *=== End of subroutine Dpmrun =========================================* END * *===aaevt==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL * event flag COMMON /DTEVNO/ NEVENT,ICASCA LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW C COMMON /PRTANU/ IAPROJ,IATARG cdh CHARACTER*8 DATE,HHMMSS cdh DIMENSION IDMNYR(3) CHARACTER*10 DATE(3) CHARACTER*8 HHMMSS DIMENSION IDMNYR(8) 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 cdh CALL IDATE(IDMNYR) cdh CALL ITIME(IDMNYR) CALL DATE_AND_TIME(DATE(1),DATE(2),DATE(3),IDMNYR) WRITE(DATE,'(I4,''/'',I2,''/'',I2)') & IDMNYR(1),IDMNYR(2),IDMNYR(3) WRITE(HHMMSS,'(I4,'':'',I2,'':'',I2)') & IDMNYR(5),IDMNYR(6),IDMNYR(7) IF (LPRI.GT.4) &WRITE(LOUT,1001) DATE(1),DATE(2) 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, & ' Time: ',A10,' )') WRITE(DATE,'(I4,''/'',I2,''/'',I2)') & IDMNYR(1),IDMNYR(2),IDMNYR(3) * generate NEVTS events DO 2 IEVT=1,NEVTS * print run-status message IF (MOD(IEVT,NMSG).EQ.0) THEN cdh CALL IDATE(IDMNYR) cdh CALL ITIME(IDMNYR) CALL DATE_AND_TIME(DATE(1),DATE(2),DATE(3),IDMNYR) WRITE(DATE,'(I4,''/'',I2,''/'',I2)') & IDMNYR(1),IDMNYR(2),IDMNYR(3) WRITE(HHMMSS,'(I4,'':'',I2,'':'',I2)') & IDMNYR(5),IDMNYR(6),IDMNYR(7) IF (LPRI.GT.4) & WRITE(LOUT,1000) IEVT-1,NEVTS,DATE(1),DATE(2) 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A8, & ' Time: ',A10,' )',/) C WRITE(LOUT,1000) IEVT-1 C1000 FORMAT(1X,I8,' events sampled') ENDIF NEVENT = IEVT * treat nuclear emulsions * composite targets only IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) KKMAT = -KKMAT * sample this event CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) C chain fusion C WRITE(6,*)' IFUSION,IAPROJ,IATARG ',IFUSION,IAPROJ,IATARG IF((IFUSION.EQ.1).AND.(NPMASS.GT.12).AND.(NTMASS.GT.12)) & CALL DT_DENSITY * * 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 * *===absorp=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, & ONETHI=0.3333D0,TWOTHI=0.6666D0) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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(ONE) 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 IF (LPRI.GT.4) & WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) 1001 FORMAT(1X,'DT_ABSORP: warning! inconsistent', & ' tree-particle kinematics',/,20X,'id: ',I3, & ' AAM = ',E11.4,' MFSP = ',E11.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 IF (LPRI.GT.4) & WRITE(LOUT,*)'DT_ABSORB: EMC ',AAM(IDFSP(1)), & AAM(IDFSP(2)), AM3P GOTO 9999 ENDIF ENDIF ELSE IF (LPRI.GT.4 .AND. IOULEV(3).GT.0) & WRITE(LOUT,1000) IDCAS,NSPE 1000 FORMAT(1X,'DT_ABSORP: warning! absorption for particle ',I3, & ' impossible',/,20X,'too few spectators (',I2,')') NSPE = 0 ENDIF RETURN 9999 CONTINUE IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) &WRITE(LOUT,*) 'rejected 1 in DT_ABSORP' IREJ = 1 RETURN END * *===beam===============================================================* * CDECK ID>, DT_BEAMPR SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) ************************************************************************ * Initialization of event generation * * This version dated 7.4.98 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) LOGICAL LBEAM * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * beam momenta COMMON /DTBEAM/ P1(4),P2(4) C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) DIMENSION WHAT(6),P1CMS(4),P2CMS(4) DATA LBEAM /.FALSE./ GOTO (1,2) MODE 1 CONTINUE E1 = WHAT(1) IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) E2 = WHAT(2) IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) TH = 1.D-6*WHAT(3)/2.D0 PH = WHAT(4)*BOG P1(1) = PP1*SIN(TH)*COS(PH) P1(2) = PP1*SIN(TH)*SIN(PH) P1(3) = PP1*COS(TH) P1(4) = E1 P2(1) = PP2*SIN(TH)*COS(PH) P2(2) = PP2*SIN(TH)*SIN(PH) P2(3) = -PP2*COS(TH) P2(4) = E2 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 & -(P1(3)+P2(3))**2 ) ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) BGX = (P1(1)+P2(1))/ECM BGY = (P1(2)+P2(2))/ECM BGZ = (P1(3)+P2(3))/ECM BGE = (P1(4)+P2(4))/ECM CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) COD = P1CMS(3)/P1TOT C SID = SQRT((ONE-COD)*(ONE+COD)) PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) SID = PPT/P1TOT COF = ONE SIF = ZERO IF (P1TOT*SID.GT.TINY10) THEN COF = P1CMS(1)/(SID*P1TOT) SIF = P1CMS(2)/(SID*P1TOT) ANORF = SQRT(COF*COF+SIF*SIF) COF = COF/ANORF SIF = SIF/ANORF ENDIF **check C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT C PAX = ZERO C PAY = ZERO C PAZ = P1TOT C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) C PBX = ZERO C PBY = ZERO C PBZ = -P2TOT C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, C & P1CMS(1),P1CMS(2),P1CMS(3)) C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, C & P2CMS(1),P2CMS(2),P2CMS(3)) C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), C & P1TOT,P1(1),P1(2),P1(3),P1(4)) C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), C & P2TOT,P2(1),P2(2),P2(3),P2(4)) C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) C STOP ** LBEAM = .TRUE. RETURN 2 CONTINUE IF (LBEAM) THEN IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN DO 20 I=NPOINT(4),NHKK IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. & (ISTHKK(I).EQ.1001)) THEN CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) PECMS = PHKK(4,I) CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) ENDIF 20 CONTINUE ELSE MODE = -1 ENDIF RETURN END * *===betrej=============================================================* * CDECK ID>, DT_BETREJ DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ONE=1.0D0) IF (XMIN.GE.XMAX)THEN IF (LPRI.GT.4) & WRITE (LOUT,500) XMIN,XMAX 500 FORMAT(1X,'DT_BETREJ: XMIN, DT_BLKD43 BLOCK DATA DT_BLKD43 IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE *$ CREATE REAC.ADD *COPY REAC * *=== reac =============================================================* * *----------------------------------------------------------------------* * * * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * * Infn - Milan * * * * Last change on 18-dec-2012 by S.Roesler * * * * 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 ak0 n * * * DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, * KN reaction channels corrected as pointed out by A.Ferrari 18/12/12 C & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 21, 23, 22, 13, & 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, * nn reaction channels corrected as pointed out by A.Ferrari 18/12/12 C & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / & 1, 56, 8, 55, 8, 64, 1, 60, 8, 59, 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 * *===blkd46=============================================================* * CDECK ID>, DT_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 * *===blkd47=============================================================* * CDECK ID>, DT_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 * *===ch2res=============================================================* * CDECK ID>, DT_CH2RES SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, & AM,AMN,IMODE,IREJ) ************************************************************************ * Check chains for resonance production. * * This subroutine replaces COMCMA/COBCMA/COMCM2 * * input: * * IF1,2,3,4 input flavors (q,aq in any order) * * AM chain mass * * MODE = 1 check q-aq chain for meson-resonance * * = 2 check q-qq, aq-aqaq chain for baryon-resonance * * = 3 check qq-aqaq chain for lower mass cut * * output: * * IDR = 0 no resonances found * * = -1 pseudoscalar meson/octet baryon * * = 1 vector-meson/decuplet baryon * * IDXR BAMJET-index of corresponding resonance * * AMN mass of corresponding resonance * * * * IREJ rejection flag * * This version dated 06.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * quark-content to particle index conversion (DTUNUC 1.x) COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), & IA08(6,21),IA10(6,21) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW **sr 4.7. test C DATA AMLOM,AMLOB /0.08D0,0.2D0/ DIMENSION IF(4),JF(4) DATA AMLOM,AMLOB /0.1D0,0.7D0/ ** C DATA AMLOM,AMLOB /0.001D0,0.001D0/ MODE = ABS(IMODE) IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) MODE 1000 FORMAT(1X,'DT_CH2RES: MODE ',I4,' not supported!',/, & 1X,' program stopped') STOP ENDIF AMX = AM IREJ = 0 IDR = 0 IDXR = 0 AMN = AMX IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB IF(1) = IF1 IF(2) = IF2 IF(3) = IF3 IF(4) = IF4 NF = 0 DO 100 I=1,4 IF (IF(I).NE.0) THEN NF = NF+1 JF(NF) = IF(I) ENDIF 100 CONTINUE IF (NF.LE.MODE) THEN IF (LPRI.GT.4) & WRITE(LOUT,1001) MODE,IF 1001 FORMAT(1X,'DT_CH2RES: inconsistent input flavors in MODE ', & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) GOTO 9999 ENDIF GOTO (1,2,3) MODE * check for meson resonance 1 CONTINUE IFQ = JF(1) IFAQ = ABS(JF(2)) IF (JF(2).GT.0) THEN IFQ = JF(2) IFAQ = ABS(JF(1)) ENDIF IFPS = IMPS(IFAQ,IFQ) IFV = IMVE(IFAQ,IFQ) AMPS = AAM(IFPS) AMV = AAM(IFV) AMHI = AMV+0.3D0 IF (AMX.LT.AMV) THEN IF (AMX.LT.AMPS) THEN IF (IMODE.GT.0) THEN IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 ELSE IF (AMX.LT.0.8D0*AMPS) GOTO 9999 ENDIF LOMRES = LOMRES+1 ENDIF * replace chain by pseudoscalar meson IDR = -1 IDXR = IFPS AMN = AMPS ELSEIF (AMX.LT.AMHI) THEN * replace chain by vector-meson IDR = 1 IDXR = IFV AMN = AMV ENDIF RETURN * check for baryon resonance 2 CONTINUE CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) AM8 = AAM(JB8) AM10 = AAM(JB10) AMHI = AM10+0.3D0 IF (AMX.LT.AM10) THEN IF (AMX.LT.AM8) THEN IF (IMODE.GT.0) THEN IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 ELSE IF (AMX.LT.0.8D0*AM8) GOTO 9999 ENDIF LOBRES = LOBRES+1 ENDIF * replace chain by oktet baryon IDR = -1 IDXR = JB8 AMN = AM8 ELSEIF (AMX.LT.AMHI) THEN IDR = 1 IDXR = JB10 AMN = AM10 ENDIF RETURN * check qq-aqaq for lower mass cut 3 CONTINUE * empirical definition of AMHI to allow for (b-antib)-pair prod. AMHI = 2.5D0 IF (AMX.LT.AMHI) GOTO 9999 RETURN 9999 CONTINUE IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0) .AND. LPRI.GT.4) & WRITE(LOUT,*) 'rejected 1 in DT_CH2RES',IMODE IREJ = 1 IRRES(2) = IRRES(2)+1 RETURN END * *===chasta=============================================================* * CDECK ID>, DT_CHASTA SUBROUTINE DT_CHASTA(MODE) ************************************************************************ * This subroutine performs CHAin STAtistics and checks sequence of * * partons in dtevt1 and sorts them with projectile partons coming * * first if necessary. * * * * This version dated 8.5.00 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI CHARACTER*5 CCHTYP * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * pointer to chains in hkkevt common (used by qq-breaking mechanisms) PARAMETER (MAXCHN=10000) COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), & CCHTYP(9),ICHSTA(10),ITOT(10) DATA ICHCFG /1800*0/ DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', & 'ad aq',' d ad','ad d ',' g g '/ * * initialization * IF (MODE.EQ.-1) THEN NCHAIN = 0 * * loop over DTEVT1 and analyse chain configurations * ELSEIF (MODE.EQ.0) THEN DO 21 IDX=NPOINT(3),NHKK IDCHK = IDHKK(IDX)/10000 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. & (IDHKK(IDX).NE.80000).AND. & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN IF (LPRI.GT.4) & WRITE(LOUT,*)' DT_CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', & ' at entry ',IDX GOTO 21 ENDIF * IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) IMO1 = IST1/10 IMO1 = IST1-10*IMO1 IMO2 = IST2/10 IMO2 = IST2-10*IMO2 * swop parton entries if necessary since we need projectile partons * to come first in the common IF (IMO1.GT.IMO2) THEN NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 DO 22 K=1,NPTN/2 I0 = JMOHKK(1,IDX)-1+K I1 = JMOHKK(2,IDX)+1-K ITMP = ISTHKK(I0) ISTHKK(I0) = ISTHKK(I1) ISTHKK(I1) = ITMP ITMP = IDHKK(I0) IDHKK(I0) = IDHKK(I1) IDHKK(I1) = ITMP IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) & JDAHKK(1,JMOHKK(1,I0)) = I1 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) & JDAHKK(2,JMOHKK(1,I0)) = I1 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) & JDAHKK(1,JMOHKK(2,I0)) = I1 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) & JDAHKK(2,JMOHKK(2,I0)) = I1 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) & JDAHKK(1,JMOHKK(1,I1)) = I0 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) & JDAHKK(2,JMOHKK(1,I1)) = I0 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) & JDAHKK(1,JMOHKK(2,I1)) = I0 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) & JDAHKK(2,JMOHKK(2,I1)) = I0 ITMP = JMOHKK(1,I0) JMOHKK(1,I0) = JMOHKK(1,I1) JMOHKK(1,I1) = ITMP ITMP = JMOHKK(2,I0) JMOHKK(2,I0) = JMOHKK(2,I1) JMOHKK(2,I1) = ITMP ITMP = JDAHKK(1,I0) JDAHKK(1,I0) = JDAHKK(1,I1) JDAHKK(1,I1) = ITMP ITMP = JDAHKK(2,I0) JDAHKK(2,I0) = JDAHKK(2,I1) JDAHKK(2,I1) = ITMP DO 23 J=1,4 RTMP1 = PHKK(J,I0) RTMP2 = VHKK(J,I0) RTMP3 = WHKK(J,I0) PHKK(J,I0) = PHKK(J,I1) VHKK(J,I0) = VHKK(J,I1) WHKK(J,I0) = WHKK(J,I1) PHKK(J,I1) = RTMP1 VHKK(J,I1) = RTMP2 WHKK(J,I1) = RTMP3 23 CONTINUE RTMP1 = PHKK(5,I0) PHKK(5,I0) = PHKK(5,I1) PHKK(5,I1) = RTMP1 ITMP = IDRES(I0) IDRES(I0) = IDRES(I1) IDRES(I1) = ITMP ITMP = IDXRES(I0) IDXRES(I0) = IDXRES(I1) IDXRES(I1) = ITMP ITMP = NOBAM(I0) NOBAM(I0) = NOBAM(I1) NOBAM(I1) = ITMP ITMP = IDBAM(I0) IDBAM(I0) = IDBAM(I1) IDBAM(I1) = ITMP ITMP = IDCH(I0) IDCH(I0) = IDCH(I1) IDCH(I1) = ITMP ITMP = IHIST(1,I0) IHIST(1,I0) = IHIST(1,I1) IHIST(1,I1) = ITMP ITMP = IHIST(2,I0) IHIST(2,I0) = IHIST(2,I1) IHIST(2,I1) = ITMP 22 CONTINUE ENDIF IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) * * parton 1 (projectile side) IF (IST1.EQ.21) THEN IDX1 = 1 ELSEIF (IST1.EQ.22) THEN IDX1 = 2 ELSEIF (IST1.EQ.31) THEN IDX1 = 3 ELSEIF (IST1.EQ.32) THEN IDX1 = 4 ELSEIF (IST1.EQ.41) THEN IDX1 = 5 ELSEIF (IST1.EQ.42) THEN IDX1 = 6 ELSEIF (IST1.EQ.51) THEN IDX1 = 7 ELSEIF (IST1.EQ.52) THEN IDX1 = 8 ELSEIF (IST1.EQ.61) THEN IDX1 = 9 ELSEIF (IST1.EQ.62) THEN IDX1 = 10 ELSE c WRITE(LOUT,*) c & ' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*) & ' DT_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 & ' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*) & ' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_CHASTA: NCHAIN > MAXCHN ! ', & NCHAIN,MAXCHN STOP ENDIF IDXCHN(1,NCHAIN) = IDX IDXCHN(2,NCHAIN) = ITYPE ELSE IF (LPRI.GT.4) & WRITE(LOUT,*) & ' DT_CHASTA: inconsistent chain at entry ',IDX GOTO 21 ENDIF ENDIF 21 CONTINUE * * write statistics to output unit * ELSEIF (MODE.EQ.1) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(/,A)')' DT_CHASTA: generated chain configurations' DO 31 I=1,10 IF (LPRI.GT.4) & WRITE(LOUT,'(/,2A)') & ' -----------------------------------------', & '------------------------------------' IF (LPRI.GT.4) & WRITE(LOUT,'(2A)') & ' p\\t 21 22 31 32 41', & ' 42 51 52 61 62' IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_CHASTA: MODE ',MODE,' not supported !' STOP ENDIF RETURN END * *===chkcen=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * 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 * *===chkcsy=============================================================* * CDECK ID>, DT_CHKCSY SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) ************************************************************************ * CHeCk Chain SYstem for consistency of partons at chain ends. * * ID1,ID2 PDG-numbers of partons at chain ends * * LCHK = .true. consistent chain * * = .false. inconsistent chain * * This version dated 18.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LCHK LCHK = .TRUE. * q-aq chain IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN IF (ID1*ID2.GT.0) LCHK = .FALSE. * q-qq, aq-aqaq chain ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN IF (ID1*ID2.LT.0) LCHK = .FALSE. * qq-aqaq chain ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN IF (ID1*ID2.GT.0) LCHK = .FALSE. ENDIF RETURN END * *===chkine=============================================================* * CDECK ID>, DT_CHKINE SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, & AMCH1,AMCH1N,AMCH2,IREJ) ************************************************************************ * This subroutine replaces CORMOM. * * This version dated 05.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10) * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), & PP1I(4),PP2I(4),PT1I(4),PT2I(4) IREJ = 0 JMSHL = IMSHL SCALE = AMCH1N/MAX(AMCH1,TINY10) DO 10 I=1,4 PP1(I) = PP1I(I) PP2(I) = PP2I(I) PT1(I) = PT1I(I) PT2(I) = PT2I(I) PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) PP1(I) = SCALE*PP1(I) PT1(I) = SCALE*PT1(I) 10 CONTINUE IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 ECH = PP2(4)+PT2(4) PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ & (PP2(3)+PT2(3))**2 ) AMCH22 = (ECH-PCH)*(ECH+PCH) IF (AMCH22.LT.0.0D0) THEN IF (IOULEV(1).GT.0 .AND. LPRI.GT.4) & WRITE(LOUT,'(1X,A)') 'DT_CHKINE: inconsistent treatment!' GOTO 9997 ENDIF AMCH1 = AMCH1N AMCH2 = SQRT(AMCH22) * put partons again on mass shell 13 CONTINUE XM1 = 0.0D0 XM2 = 0.0D0 IF (JMSHL.EQ.1) THEN XM1 = PYMASS(IFP1) XM2 = PYMASS(IFT1) ENDIF CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) THEN IF (JMSHL.EQ.0) GOTO 9998 JMSHL = 0 GOTO 13 ENDIF JMSHL = IMSHL DO 11 I=1,4 PP1(I) = P1(I) PT1(I) = P2(I) 11 CONTINUE 14 CONTINUE XM1 = 0.0D0 XM2 = 0.0D0 IF (JMSHL.EQ.1) THEN XM1 = PYMASS(IFP2) XM2 = PYMASS(IFT2) ENDIF CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) THEN IF (JMSHL.EQ.0) GOTO 9998 JMSHL = 0 GOTO 14 ENDIF DO 12 I=1,4 PP2(I) = P1(I) PT2(I) = P2(I) 12 CONTINUE DO 15 I=1,4 PP1I(I) = PP1(I) PP2I(I) = PP2(I) PT1I(I) = PT1(I) PT2I(I) = PT2(I) 15 CONTINUE RETURN 9997 IRCHKI(1) = IRCHKI(1)+1 **sr C GOTO 9999 IREJ = -1 RETURN ** 9998 IRCHKI(2) = IRCHKI(2)+1 **af *9999 CONTINUE IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) &WRITE(LOUT,*) 'rejected 1 in DT_CHKINE' IREJ = 1 RETURN END * *===ckmt===============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 C * *===ckmtde=============================================================* * CDECK ID>, 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 C IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN 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 * *===ckmtff=============================================================* * CDECK ID>, 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 C * *===ckmtpr=============================================================* * CDECK ID>, DT_CKMTDE CDECK ID>, 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 C IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN 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 * *===ckmtq0=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I4,A)') & 'DT_CKMTQ0: IPAR =',IPAR,' not implemented!' STOP ENDIF RETURN END C * *===ckmtx==============================================================* * CDECK ID>, 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI DIMENSION QQ(7) C Q2=SNGL(SCALE2) Q1S=Q2 XX=SNGL(X) C QCD lambda for evolution OWLAM = 0.23 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I4,A)') & 'DT_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 * *===com2sr=============================================================* * CDECK ID>, DT_COM2CR SUBROUTINE DT_COM2CR ************************************************************************ * COMbine q-aq chains to Color Ropes (qq-aqaq). * * CUTOF parameter determining minimum number of not * * combined q-aq chains * * This subroutine replaces KKEVCC etc. * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT DIMENSION IDXQA(248),IDXAQ(248) ICCHAI(1,9) = ICCHAI(1,9)+1 NQA = 0 NAQ = 0 * scan DTEVT1 for q-aq, aq-q chains DO 10 I=NPOINT(3),NHKK * skip "chains" which are resonances IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN MO1 = JMOHKK(1,I) MO2 = JMOHKK(2,I) IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN * q-aq, aq-q chain found, keep index IF (IDHKK(MO1).GT.0) THEN NQA = NQA+1 IDXQA(NQA) = I ELSE NAQ = NAQ+1 IDXAQ(NAQ) = I ENDIF ENDIF ENDIF 10 CONTINUE * minimum number of q-aq chains requested for the same projectile/ * target NCHMIN = IDT_NPOISS(CUTOF) * combine q-aq chains of the same projectile CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) * combine q-aq chains of the same target CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) * combine aq-q chains of the same projectile CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) * combine aq-q chains of the same target CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) RETURN END * *===conucl=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===coordi=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===cqpair=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * 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 * *===cromsc=============================================================* * CDECK ID>, DT_CROMSC SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) ************************************************************************ * Cronin-Effect. Multiple scattering of one parton passing through * * nuclear matter. * * PIN(4) input 4-momentum of parton * * POUT(4) 4-momentum of parton after mult. scatt. * * R(3) spatial position of parton in target nucleus * * INCL = 1 multiple sc. in projectile * * = 2 multiple sc. in target * * This is a revised version of the original version written by J. Ranft* * This version dated 17.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) LOGICAL LSTART * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT DIMENSION PIN(4),POUT(4),R(3) DATA LSTART /.TRUE./ IRCRON(1) = IRCRON(1)+1 IF (LSTART) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) CRONCO 1000 FORMAT(/,1X,'DT_CROMSC: multiple scattering of chain ends', & ' treated',/,10X,'with parameter CRONCO = ',F5.2) LSTART = .FALSE. ENDIF NCBACK = 0 RNCL = RPROJ IF (INCL.EQ.2) RNCL = RTARG * Lorentz-transformation into Lab. MODE = -(INCL+1) CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) IF (PTOT.LE.8.0D0) GOTO 9997 * direction cosines of parton before mult. scattering COSX = PIN(1)/PTOT COSY = PIN(2)/PTOT COSZ = PZ/PTOT RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 IF (RTESQ.GE.-TINY3) GOTO 9999 * calculate distance (DIST) from R to surface of nucleus (radius RNCL) * in the direction of particle motion A = COSX*R(1)+COSY*R(2)+COSZ*R(3) TMP = A**2-RTESQ IF (TMP.LT.ZERO) GOTO 9998 DIST = -A+SQRT(TMP) * multiple scattering angle THETO = CRONCO*SQRT(DIST)/PTOT IF (THETO.GT.0.1D0) THETO=0.1D0 1 CONTINUE * Gaussian sampling of spatial angle CALL DT_RANNOR(R1,R2) THETA = ABS(R1*THETO) IF (THETA.GT.0.3D0) GOTO 9997 CALL DT_DSFECF(SFE,CFE) COSTH = COS(THETA) SINTH = SIN(THETA) * new direction cosines CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, & COSXN,COSYN,COSZN) POUT(1) = COSXN*PTOT POUT(2) = COSYN*PTOT PZ = COSZN*PTOT * Lorentz-transformation into nucl.-nucl. cms MODE = INCL+1 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN THETO = THETO/2.0D0 NCBACK = NCBACK+1 IF (MOD(NCBACK,200).EQ.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,1001) THETO,PIN,POUT 1001 FORMAT(1X,'DT_CROMSC: inconsistent scattering angle ', & E12.4,/,1X,' PIN :',4E12.4,/, & 1X,' POUT:',4E12.4) GOTO 9997 ENDIF GOTO 1 ENDIF RETURN 9997 IRCRON(2) = IRCRON(2)+1 GOTO 9999 9998 IRCRON(3) = IRCRON(3)+1 9999 CONTINUE DO 100 K=1,4 POUT(K) = PIN(K) 100 CONTINUE RETURN END * *===cronin=============================================================* * CDECK ID>, DT_CRONIN SUBROUTINE DT_CRONIN(INCL) ************************************************************************ * Cronin-Effect. Multiple scattering of partons at chain ends. * * INCL = 1 multiple sc. in projectile * * = 2 multiple sc. in target * * This version dated 05.01.96 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D+00,TINY3=1.0D-03) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC DIMENSION R(3),PIN(4),POUT(4),DEV(4) DO 1 K=1,4 DEV(K) = ZERO 1 CONTINUE DO 2 I=NPOINT(2),NHKK IF (ISTHKK(I).LT.0) THEN * get z-position of the chain R(1) = VHKK(1,I)*1.0D12 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC R(2) = VHKK(2,I)*1.0D12 IDXNU = JMOHKK(1,I) IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) & IDXNU = JMOHKK(1,I-1) IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) & IDXNU = JMOHKK(1,I+1) R(3) = VHKK(3,IDXNU)*1.0D12 * position of target parton the chain is connected to DO 3 K=1,4 PIN(K) = PHKK(K,I) 3 CONTINUE * multiple scattering of parton with DTEVT1-index I CALL DT_CROMSC(PIN,R,POUT,INCL) **testprint C IF (NEVHKK.EQ.5) THEN C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU C WRITE(6,'(A,4E15.5)')'PIN: ',PIN C WRITE(6,'(A,4E15.5)')'POUT: ',POUT C ENDIF ** * increase accumulator by energy-momentum difference DO 4 K=1,4 DEV(K) = DEV(K)+POUT(K)-PIN(K) PHKK(K,I) = POUT(K) 4 CONTINUE PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- & PHKK(2,I)**2-PHKK(3,I)**2)) ENDIF 2 CONTINUE * dump accumulator to momenta of valence partons NVAL = 0 ETOT = 0.0D0 DO 5 I=NPOINT(2),NHKK IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN NVAL = NVAL+1 ETOT = ETOT+PHKK(4,I) ENDIF 5 CONTINUE C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) C1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, C & 9X,4E12.4) DO 6 I=NPOINT(2),NHKK IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN E = PHKK(4,I) DO 7 K=1,4 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT 7 CONTINUE PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- & PHKK(2,I)**2-PHKK(3,I)**2)) ENDIF 6 CONTINUE RETURN END * *===daltra=============================================================* * CDECK ID>, DT_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 * *===damg===============================================================* * CDECK ID>, DT_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 * *===dbetar=============================================================* * CDECK ID>, DT_DBETAR DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) ************************************************************************ * Sampling from Beta -distribution between 0.0 and 1.0 * * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* * Processed by S. Roesler, 6.5.95 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE Y = DT_DGAMRN(1.0D0,GAM) Z = DT_DGAMRN(1.0D0,ETA) DT_DBETAR = Y/(Y+Z) RETURN END * *===dbklas=============================================================* * CDECK ID>, DT_DBKLAS SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * 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) * baryons IF (I) 20,20,10 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 * *===dbreak=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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) .AND. LPRI.GT.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 IF (LPRI.GT.4) & 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 * *===dcalum=============================================================* * CDECK ID>, DT_DCALUM SUBROUTINE DT_DCALUM(N,ITTA) C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION 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 /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 * *===dchanh=============================================================* * CDECK ID>, DT_DCHANH SUBROUTINE DT_DCHANH IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * 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 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 C1000 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 HWT(J)=0.D0 100 CONTINUE 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 (LPRI.GT.4 .AND. 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 WTI(J)=HWT(J) 130 CONTINUE RETURN END * *===dchant=============================================================* * CDECK ID>, DT_DCHANT SUBROUTINE DT_DCHANT IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 (LPRI.GT.4 .AND. 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 * *===ddatar=============================================================* * CDECK ID>, DT_DDATAR SUBROUTINE DT_DDATAR IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===decay1=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 * *===decay==============================================================* * CDECK ID>, DT_DECAYS 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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, & IFUSION,IFLOW 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 * *===decpi0=============================================================* * CDECK ID>, DT_DECPI0 SUBROUTINE DT_DECPI0 ************************************************************************ * Decay of pi0 handled with JETSET. * * This version dated 11.11.12 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) * event history PARAMETER (NMXHKK=250000) 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) SAVE /PYDAT3/ INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ * 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, & IFUSION,IFLOW 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 INI = 0 I0 = 1 I1 = NHKK IACT = 0 NNMAX = MAXLND/4 5 CONTINUE NN = 0 DO 1 I=I0,I1 IF (NN.EQ.NNMAX) THEN I0 = I GOTO 4 ENDIF 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 IACT = I 1 CONTINUE 4 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 IF (IACT.NE.I1) GOTO 5 MDCY(KC,1) = 0 RETURN END * *===defaul=============================================================* * CDECK ID>, DT_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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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, & IFUSION,IFLOW * 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 cdh do not overwrite the glauber data set name of corsika cdh 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 * *===defset=============================================================* * CDECK ID>, DT_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, & IFUSION,IFLOW * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * / 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 / * / DTFLKA / DATA LINP,LOUT,LDAT / 5, 19, 9/ END * *===densit=============================================================* * CDECK ID>, DT_DENSIT DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===density============================================================* * SUBROUTINE DT_DENSITY IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * event history PARAMETER (NMXHKK=250000) 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 /DTFLKA/ LINP,LOUT,LDAT, LPRI * Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ * flags LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW C DIMENSION ICHAIM(30,30),KCHAIM(30,30,600) COMMON /ZAZAKE/ ZAKEIN(100) C--------------------- * DATA NCOUNT/0/ *. AABBFUS=0.81D0*(1.D0-5.D0/SQRT(UMO)) AABBFUS=0.45D0 C parameters im dpm3304 IF(UMO.GT.100.D0)AABBFUS=0.45D0 IF(UMO.LT.20.D0)AABBFUS=0.0D0 IF(UMO.GT.20.D0.AND.UMO.LT.100.D0)AABBFUS=0.45D0*(UMO-20.D0)/80.D0 IF(LPRI.GT.4) THEN IF(NCOUNT.LE.5)WRITE(6,*)" UMO,AABBFUS =",UMO,AABBFUS END IF C paarameters in dpm3influka IF(UMO.GT.100.D0)AABBFUS=0.53D0 IF(UMO.LT.20.D0)AABBFUS=0.0D0 IF(UMO.GT.20.D0.AND.UMO.LT.100.D0)AABBFUS=0.53D0*(UMO-20.D0)/80.D0 IF(LPRI.GT.4) THEN IF(NCOUNT.LE.5)WRITE(6,*)" UMO,AABBFUS =",UMO,AABBFUS END IF NCHAIN=0 NCHAINN=0 NCHAIN31=0 NCHAIN32=0 NCHAIN33=0 NCHAIN34=0 NCHAIN21=0 NCHAIN22=0 NCOUNT=NCOUNT+1 DAAA=0.9D0 DAAA=1.D0 DAAA=1.2D0 DAAA=1.5D0 DAAA=1.8D0 C First round of fusions C WRITE(6,*)' entry density' DO 7776 IIX=1,30 DO 7775 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 7774 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 7774 CONTINUE 7775 CONTINUE 7776 CONTINUE DO 4477 JJKEIN=1,100 ZAKEIN(JJKEIN)=0.D0 4477 CONTINUE C DO 7667 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.7)GO TO 7667 IF(IDH.GT.8)GO TO 7667 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) RRKEIN=1.D12*SQRT(VHKK(1,KK)**2+VHKK(2,KK)**2) IIKEIN=RRKEIN/0.2D0 +2.D0 DO 4567 JJKEIN=IIKEIN,100 ZAKEIN(JJKEIN)=ZAKEIN(JJKEIN)+1 4567 CONTINUE 7667 CONTINUE C C DO 7777 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.7)GO TO 7777 IF(IDH.GT.8)GO TO 7777 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.D0+1.D12*VHKK(1,KK)/DAAA IIY=15.D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 NCHAIN=NCHAIN+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 7777 CONTINUE C IF(NCOUNT.LE.3)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 7778 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 7778 CONTINUE WRITE(6,*)' ZAKEIN ' DO 3477 JJKEIN=1,100 WRITE(6,*)JJKEIN,ZAKEIN(JJKEIN) 3477 CONTINUE END IF END IF IF(IFLOW.EQ.1)THEN C WRITE(6,*)' and now KETWW ' C CALL KETWW(ZAKEIN) END IF C First round of fusions DO 5667 IIX=8,22 DO 5668 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 5668 DO 6556 KKK=1,ICHAIM(IIX,IIY)-1 DO 6557 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.7)GO TO 6556 IF(KK.GT.8)GO TO 6556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.7)GO TO 6557 IF(LL.GT.8)GO TO 6557 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 6557 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) DO 6558 MMM=1,ICHAIM(IIX,IIY) MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.7)GO TO 6558 IF(MM.GT.8)GO TO 6558 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.7)GO TO 6557 IF(LL.GT.8)GO TO 6557 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.7)GO TO 6556 IF(KK.GT.8)GO TO 6556 IF(MMM.EQ.KKK.OR.MMM.EQ.LLL)GO TO 6558 RKM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) RLM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,LLL))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,LLL))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) IF(RKM.GT.AABBFUS.AND.RLM.GT.AABBFUS)GO TO 6558 IDM=IDHKK(KCHAIM(IIX,IIY,MMM)) IDM1=IDHKK(KCHAIM(IIX,IIY,MMM)-2) IDM2=IDHKK(KCHAIM(IIX,IIY,MMM)-1) IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.-1.AND.IDL1.GE.-4).AND. * (IDL2.GE.1.AND.IDL2.LE.4)))THEN IF((IDK1.EQ.-IDL1).AND.(IDK2.EQ.-IDL2))THEN C q-aq and aq-q chains C WRITE(6,*)IIX,IIY,KKK,LLL,MMM, C * ' RKL,RKM ',RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL), C * KCHAIM(IIX,IIY,MMM),IDK,IDL,IDM CALL DT_JOIN3(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN31=NCHAIN31+1 C IF(IREJ.NE.0) C * WRITE(6,*)'Rejection in JOIN3' END IF END IF KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.7)GO TO 6556 IF(KK.GT.8)GO TO 6556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.7)GO TO 6557 IF(LL.GT.8)GO TO 6557 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.7)GO TO 6556 IF(KK.GT.8)GO TO 6556 IF(((IDK2.LE.4.AND.IDK2.GE.1).AND. * (IDK1.GE.-4.AND.IDK1.LE.-1)).AND. * ((IDL2.LE.-1.AND.IDL2.GE.-4).AND. * (IDL1.GE.1.AND.IDL1.LE.4)))THEN IF((IDK1.EQ.-IDL1).AND.(IDK2.EQ.-IDL2))THEN C aq-q and q-aq chains C WRITE(6,*)IIX,IIY,KKK,LLL,MMM, C * ' RKL,RKM ',RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN3(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN31=NCHAIN31+1 C IF(IREJ.NE.0) C * WRITE(6,*)'Rejection in JOIN3' END IF END IF 6558 CONTINUE 6557 CONTINUE 6556 CONTINUE 5668 CONTINUE 5667 CONTINUE C First' round of fusions C WRITE(6,*)' entry density' DO 7716 IIX=1,30 DO 7715 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 7714 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 7714 CONTINUE 7715 CONTINUE 7716 CONTINUE C DO 7717 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.7)GO TO 7717 IF(IDH.GT.8)GO TO 7717 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.D0+1.D12*VHKK(1,KK)/DAAA IIY=15.D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 C NCHAIN=NCHAIN+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 7717 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 7718 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 7718 CONTINUE END IF END IF C First' round of fusions include 66666 chains DO 5617 IIX=8,22 DO 5618 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 5618 DO 6516 KKK=1,ICHAIM(IIX,IIY)-1 DO 6517 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6516 IF(KK.GT.8)GO TO 6516 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.7)GO TO 6517 IF(LL.GT.8)GO TO 6517 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 6517 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) DO 6518 MMM=1,ICHAIM(IIX,IIY) MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.6)GO TO 6518 IF(MM.GT.8)GO TO 6518 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 6517 IF(LL.GT.8)GO TO 6517 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6516 IF(KK.GT.8)GO TO 6516 IF(MMM.EQ.KKK.OR.MMM.EQ.LLL)GO TO 6518 RKM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) RLM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,LLL))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,LLL))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) IF(RKM.GT.AABBFUS.AND.RLM.GT.AABBFUS)GO TO 6518 IDM=IDHKK(KCHAIM(IIX,IIY,MMM)) IDM1=IDHKK(KCHAIM(IIX,IIY,MMM)-2) IDM2=IDHKK(KCHAIM(IIX,IIY,MMM)-1) IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.-1.AND.IDL1.GE.-4).AND. * (IDL2.GE.1.AND.IDL2.LE.4)))THEN IDMM1=IDM2/1000 IDMM2=(IDM2-IDMM1*1000)/100 IF(((IDK2.EQ.-IDMM1).OR. * (IDK2.EQ.-IDMM2)).AND. * (IDL1.EQ.-IDM1))THEN C q-aq and aq-q chains plus q-qq chain C WRITE(6,*)IIX,IIY,KKK,LLL,MMM, C * ' RKL,RKM ',RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN33(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ ) IF(IREJ.EQ.0)NCHAIN33=NCHAIN33+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN33' END IF END IF KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6516 IF(KK.GT.8)GO TO 6516 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 6517 IF(LL.GT.8)GO TO 6517 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6516 IF(KK.GT.8)GO TO 6516 IF(((IDK2.LE.4.AND.IDK2.GE.1).AND. * (IDK1.GE.-4.AND.IDK1.LE.-1)).AND. * ((IDL2.LE.-1.AND.IDL2.GE.-4).AND. * (IDL1.GE.1.AND.IDL1.LE.4)))THEN IDMM1=IDM1/1000 IDMM2=(IDM1-IDMM1*1000)/100 IF(((IDK1.EQ.-IDMM1).OR. * (IDK1.EQ.-IDMM2)).AND. * (IDL2.EQ.-IDM2))THEN C aq-q and q-aq chains and qq-q chain C WRITE(6,*)IIX,IIY,KKK,LLL,MMM, C * ' RKL,RKM ',RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN333(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN33=NCHAIN33+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN333' END IF END IF 6518 CONTINUE 6517 CONTINUE 6516 CONTINUE 5618 CONTINUE 5617 CONTINUE C First'' round of fusions C WRITE(6,*)' entry density' DO 7726 IIX=1,30 DO 7725 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 7724 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 7724 CONTINUE 7725 CONTINUE 7726 CONTINUE C DO 7727 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.7)GO TO 7727 IF(IDH.GT.8)GO TO 7727 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.D0+1.D12*VHKK(1,KK)/DAAA IIY=15.D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 C NCHAIN=NCHAIN+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 7727 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 7728 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 7728 CONTINUE END IF END IF C First'' round of fusions include 66666 chains DO 5627 IIX=8,22 DO 5628 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 5628 DO 6526 KKK=1,ICHAIM(IIX,IIY)-1 DO 6527 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6526 IF(KK.GT.8)GO TO 6526 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.7)GO TO 6527 IF(LL.GT.8)GO TO 6527 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 6527 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) DO 6528 MMM=1,ICHAIM(IIX,IIY) MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.6)GO TO 6528 IF(MM.GT.8)GO TO 6528 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 6527 IF(LL.GT.8)GO TO 6527 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6526 IF(KK.GT.8)GO TO 6526 IF(MMM.EQ.KKK.OR.MMM.EQ.LLL)GO TO 6528 RKM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) RLM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,LLL))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,LLL))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) IF(RKM.GT.AABBFUS.AND.RLM.GT.AABBFUS)GO TO 6528 IDM=IDHKK(KCHAIM(IIX,IIY,MMM)) IDM1=IDHKK(KCHAIM(IIX,IIY,MMM)-2) IDM2=IDHKK(KCHAIM(IIX,IIY,MMM)-1) IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.-1.AND.IDL1.GE.-4).AND. * (IDL2.GE.1.AND.IDL2.LE.4)))THEN IF((IDL2.EQ.-IDM2).AND.(IDK1.EQ.-IDL1))THEN C q-aq and aq-q chains plus q-aq chain C WRITE(6,*) IIX,IIY,KKK,LLL,MMM,' RKL,RKM ', C * RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN34(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN34=NCHAIN34+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN34' END IF END IF KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6526 IF(KK.GT.8)GO TO 6526 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 6527 IF(LL.GT.8)GO TO 6527 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 6526 IF(KK.GT.8)GO TO 6526 IF(((IDK2.LE.4.AND.IDK2.GE.1).AND. * (IDK1.GE.-4.AND.IDK1.LE.-1)).AND. * ((IDL2.LE.-1.AND.IDL2.GE.-4).AND. * (IDL1.GE.1.AND.IDL1.LE.4)))THEN IF((IDL2.EQ.-IDK2).AND.(IDL1.EQ.-IDM1))THEN C aq-q and q-aq chains and aq-q chain C WRITE(6,*) IIX,IIY,KKK,LLL,MMM,' RKL,RKM ', C * RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN344(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN34=NCHAIN34+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN344' END IF END IF 6528 CONTINUE 6527 CONTINUE 6526 CONTINUE 5628 CONTINUE 5627 CONTINUE C Second round of fusions include 66666 chains NCOUNT=NCOUNT+1 C WRITE(6,*)' entry density' DO 6776 IIX=1,30 DO 6775 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 6774 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 6774 CONTINUE 6775 CONTINUE 6776 CONTINUE C DO 6777 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.6)GO TO 6777 IF(IDH.GT.8)GO TO 6777 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.D0+1.D12*VHKK(1,KK)/DAAA IIY=15.D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 6777 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 6778 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 6778 CONTINUE END IF END IF DO 6667 IIX=8,22 DO 6668 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 6668 DO 5556 KKK=1,ICHAIM(IIX,IIY)-1 DO 5557 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5556 IF(KK.GT.8)GO TO 5556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 5557 IF(LL.GT.8)GO TO 5557 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 5557 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.1000.AND.IDK2.LE.4000)).AND. * ((IDL1.LE.4.AND.IDL1.GE.1).AND. * (IDL2.GE.-4.AND.IDL2.LE.-1)))THEN C q-qq and q-aq chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL IQQ1=IDK2/1000 IQQ2=(IDK2-IQQ1*1000)/100 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5556 IF(KK.GT.8)GO TO 5556 IF(IQQ1.EQ.-IDL2.OR.IQQ2.EQ.-IDL2)THEN C WRITE(6,*)' IQQ1,IQQ2,IDL2 ',IQQ1,IQQ2,IDL2 CALL DT_JOIN2(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * IREJ) IF(IREJ.EQ.0)NCHAIN21=NCHAIN21+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN2' END IF END IF IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.4.AND.IDL1.GE.1).AND. * (IDL2.GE.1000.AND.IDL2.LE.4000)))THEN C q-aq and q-qq chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL IQQ1=IDL2/1000 IQQ2=(IDL2-IQQ1*1000)/100 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5556 IF(KK.GT.8)GO TO 5556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 5557 IF(LL.GT.8)GO TO 5557 IF(IQQ1.EQ.-IDK2.OR.IQQ2.EQ.-IDK2)THEN C WRITE(6,*)' IQQ1,IQQ2,IDK2 ',IQQ1,IQQ2,IDK2 CALL DT_JOIN2(KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,KKK), * IREJ) IF(IREJ.EQ.0)NCHAIN21=NCHAIN21+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN2' END IF END IF 5557 CONTINUE 5556 CONTINUE 6668 CONTINUE 6667 CONTINUE C C Second' round of fusions include 66666 chains NCOUNT=NCOUNT+1 C WRITE(6,*)' entry density' DO 6676 IIX=1,30 DO 6675 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 6674 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 6674 CONTINUE 6675 CONTINUE 6676 CONTINUE C DO 6677 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.6)GO TO 6677 IF(IDH.GT.8)GO TO 6677 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.5D0+1.D12*VHKK(1,KK)/DAAA IIY=15.5D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 6677 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 6178 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 6178 CONTINUE END IF END IF DO 6167 IIX=8,22 DO 6168 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 6168 DO 5156 KKK=1,ICHAIM(IIX,IIY)-1 DO 5157 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5156 IF(KK.GT.8)GO TO 5156 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 5157 IF(LL.GT.8)GO TO 5157 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 5157 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.1000.AND.IDK2.LE.4000)).AND. * ((IDL1.LE.4.AND.IDL1.GE.1).AND. * (IDL2.GE.-4.AND.IDL2.LE.-1)))THEN C q-qq and q-aq chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL IQQ1=IDK2/1000 IQQ2=(IDK2-IQQ1*1000)/100 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5156 IF(KK.GT.8)GO TO 5156 IF(IQQ1.EQ.-IDL2.OR.IQQ2.EQ.-IDL2)THEN C WRITE(6,*)' IQQ1,IQQ2,IDL2 ',IQQ1,IQQ2,IDL2 CALL DT_JOIN2(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * IREJ) IF(IREJ.EQ.0)NCHAIN21=NCHAIN21+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN2' END IF END IF IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.4.AND.IDL1.GE.1).AND. * (IDL2.GE.1000.AND.IDL2.LE.4000)))THEN C q-aq and q-qq chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL IQQ1=IDL2/1000 IQQ2=(IDL2-IQQ1*1000)/100 KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 5156 IF(KK.GT.8)GO TO 5156 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 5157 IF(LL.GT.8)GO TO 5157 IF(IQQ1.EQ.-IDK2.OR.IQQ2.EQ.-IDK2)THEN C WRITE(6,*)' IQQ1,IQQ2,IDK2 ',IQQ1,IQQ2,IDK2 CALL DT_JOIN2(KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,KKK), * IREJ) IF(IREJ.EQ.0)NCHAIN21=NCHAIN21+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN2' END IF END IF 5157 CONTINUE 5156 CONTINUE 6168 CONTINUE 6167 CONTINUE C C Third round of fusions include 66666 chains NCOUNT=NCOUNT+1 C WRITE(6,*)' entry density' DO 5776 IIX=1,30 DO 5775 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 5774 KKI=1,600 KCHAIM(IIX,IIY,KKI)= 0 5774 CONTINUE 5775 CONTINUE 5776 CONTINUE C DO 5777 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.6)GO TO 5777 IF(IDH.GT.8)GO TO 5777 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.5D0+1.D12*VHKK(1,KK)/DAAA IIY=15.5D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 5777 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 5778 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 5778 CONTINUE END IF ENDIF DO 3667 IIX=8,22 DO 3668 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 3668 DO 3556 KKK=1,ICHAIM(IIX,IIY)-1 DO 3557 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 3556 IF(KK.GT.8)GO TO 3556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 3557 IF(LL.GT.8)GO TO 3557 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.AABBFUS)GO TO 3557 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) DO 3558 MMM=1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 3556 IF(KK.GT.8)GO TO 3556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 3557 IF(LL.GT.8)GO TO 3557 MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.6)GO TO 3558 IF(MM.GT.8)GO TO 3558 IF(MMM.EQ.KKK.OR.MMM.EQ.LLL)GO TO 3558 RKM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) RLM=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,LLL))-VHKK(1,KCHAIM(IIX,IIY,MMM)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,LLL))-VHKK(2,KCHAIM(IIX,IIY,MMM)))**2) IF(RKM.GT.AABBFUS.AND.RLM.GT.AABBFUS)GO TO 3558 IDM=IDHKK(KCHAIM(IIX,IIY,MMM)) IDM1=IDHKK(KCHAIM(IIX,IIY,MMM)-2) IDM2=IDHKK(KCHAIM(IIX,IIY,MMM)-1) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 3556 IF(KK.GT.8)GO TO 3556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 3557 IF(LL.GT.8)GO TO 3557 MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.6)GO TO 3558 IF(MM.GT.8)GO TO 3558 IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.-1.AND.IDL1.GE.-4).AND. * (IDL2.GE.1.AND.IDL2.LE.4)))THEN IF((IDK1.EQ.-IDL1).AND.(IDK2.EQ.-IDL2))THEN C q-aq and aq-q chains C WRITE(6,*)IIX,IIY,KKK,LLL,MMM,' RKL,RKM ', C * RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN3(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN32=NCHAIN32+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN3' END IF END IF KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 3556 IF(KK.GT.8)GO TO 3556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 3557 IF(LL.GT.8)GO TO 3557 MM=IDHKK(KCHAIM(IIX,IIY,MMM))/10000 IF(MM.LT.6)GO TO 3558 IF(MM.GT.8)GO TO 3558 IF(((IDK2.LE.4.AND.IDK2.GE.1).AND. * (IDK1.GE.-4.AND.IDK1.LE.-1)).AND. * ((IDL2.LE.-1.AND.IDL2.GE.-4).AND. * (IDL1.GE.1.AND.IDL1.LE.4)))THEN IF((IDK1.EQ.-IDL1).AND.(IDK2.EQ.-IDL2))THEN C aq-q and q-aq chains C WRITE(6,*)IIX,IIY,KKK,LLL,MMM,' RKL,RKM ', C * RKL,RKM,IDK1,IDK2,IDL1,IDL2,IDM1,IDM2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),KCHAIM(IIX,IIY,MMM), C * IDK,IDL,IDM CALL DT_JOIN3(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * KCHAIM(IIX,IIY,MMM), * IREJ) IF(IREJ.EQ.0)NCHAIN32=NCHAIN32+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN3' END IF END IF 3558 CONTINUE 3557 CONTINUE 3556 CONTINUE 3668 CONTINUE 3667 CONTINUE C C Fourth round of fusions include 66666 chains NCOUNT=NCOUNT+1 C WRITE(6,*)' entry density' DO 3776 IIX=1,30 DO 3775 IIY=1,30 ICHAIM(IIX,IIY)=0 DO 3774 KKI=1,400 KCHAIM(IIX,IIY,KKI)= 0 3774 CONTINUE 3775 CONTINUE 3776 CONTINUE C DO 3777 KK=1,NHKK IDH=IDHKK(KK)/10000 IF(IDH.LT.6)GO TO 3777 IF(IDH.GT.8)GO TO 3777 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4,4E12.3)') C * KK,ISTHKK(KK),IDHKK(KK), C * JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK), C * (PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK), C * (VHKK(JJ,KK),JJ=1,4) IIX=15.D0+1.D12*VHKK(1,KK)/DAAA IIY=15.D0+1.D12*VHKK(2,KK)/DAAA IF(IIX.LT.2)IIX=2 IF(IIY.LT.2)IIY=2 IF(IIX.GT.29)IIX=29 IF(IIY.GT.29)IIY=29 ICHAIM(IIX,IIY)=ICHAIM(IIX,IIY)+1 NCHAINN=NCHAINN+1 KKK=ICHAIM(IIX,IIY) KCHAIM(IIX,IIY,KKK)=KK 3777 CONTINUE C IF(NCOUNT.LE.20)THEN IF (LPRI.GT.4) THEN WRITE(6,*)' JJJ ' DO 3778 IIY=1,30 WRITE(6,'(30I3)')(ICHAIM(IIX,IIY),IIX=1,30) 3778 CONTINUE END IF END IF DO 4667 IIX=8,22 DO 4668 IIY=8,22 IF(ICHAIM(IIX,IIY).LE.1)GO TO 4668 DO 4556 KKK=1,ICHAIM(IIX,IIY)-1 DO 4557 LLL=KKK+1,ICHAIM(IIX,IIY) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 4556 IF(KK.GT.8)GO TO 4556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 4557 IF(LL.GT.8)GO TO 4557 RKL=1.D12*SQRT( * (VHKK(1,KCHAIM(IIX,IIY,KKK))-VHKK(1,KCHAIM(IIX,IIY,LLL)))**2+ * (VHKK(2,KCHAIM(IIX,IIY,KKK))-VHKK(2,KCHAIM(IIX,IIY,LLL)))**2) IF(RKL.GT.0.40D0)GO TO 4557 IDK=IDHKK(KCHAIM(IIX,IIY,KKK)) IDK1=IDHKK(KCHAIM(IIX,IIY,KKK)-2) IDK2=IDHKK(KCHAIM(IIX,IIY,KKK)-1) IDL=IDHKK(KCHAIM(IIX,IIY,LLL)) IDL1=IDHKK(KCHAIM(IIX,IIY,LLL)-2) IDL2=IDHKK(KCHAIM(IIX,IIY,LLL)-1) KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 4556 IF(KK.GT.8)GO TO 4556 IF(((IDK1.LE.4.AND.IDK1.GE.1).AND. * (IDK2.GE.-4.AND.IDK2.LE.-1)).AND. * ((IDL1.LE.4.AND.IDL1.GE.1).AND. * (IDL2.GE.-4.AND.IDL2.LE.-1)))THEN C two q-aq chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL CALL DT_JOIN(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * IREJ) IF(IREJ.EQ.0)NCHAIN22=NCHAIN22+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN ' END IF KK=IDHKK(KCHAIM(IIX,IIY,KKK))/10000 IF(KK.LT.6)GO TO 4556 IF(KK.GT.8)GO TO 4556 LL=IDHKK(KCHAIM(IIX,IIY,LLL))/10000 IF(LL.LT.6)GO TO 4557 IF(LL.GT.8)GO TO 4557 IF(((IDK2.LE.4.AND.IDK2.GE.1).AND. * (IDK1.GE.-4.AND.IDK1.LE.-1)).AND. * ((IDL2.LE.4.AND.IDL2.GE.1).AND. * (IDL1.GE.-4.AND.IDL1.LE.-1)))THEN C two aq-q chains C WRITE(6,*)IIX,IIY,KKK,LLL, C * ' RKL ',RKL,IDK1,IDK2,IDL1,IDL2, C * KCHAIM(IIX,IIY,KKK),KCHAIM(IIX,IIY,LLL),IDK,IDL CALL DT_JOIN(KCHAIM(IIX,IIY,KKK), * KCHAIM(IIX,IIY,LLL), * IREJ) IF(IREJ.EQ.0)NCHAIN22=NCHAIN22+1 C IF(IREJ.NE.0)WRITE(6,*)'Rejection in JOIN ' END IF 4557 CONTINUE 4556 CONTINUE 4668 CONTINUE 4667 CONTINUE C C WRITE(6,*)'NCHAIN,NCHAINN,NCHAIN31,NCHAIN32,NCHAIN33,NCHAIN34', C * 'NCHAIN21,NCHAIN22 ', C *NCHAIN,NCHAINN,NCHAIN31,NCHAIN32,NCHAIN33,NCHAIN34, C *NCHAIN21,NCHAIN22 C Count 22222 chains N66666=0 DO 9667 I=1,NHKK IF(IDHKK(I).EQ.66666)N66666=N66666+1 9667 CONTINUE C WRITE(6,*)' N66666 ',N66666 N22222=0 DO 1667 I=1,NHKK IF(IDHKK(I).EQ.22222)N22222=N22222+1 1667 CONTINUE * WRITE(6,*)' N22222 ',N22222 NALLL=0 DO 11667 I=1,NHKK IF(IDHKK(I)/10000.EQ.6)NALLL=NALLL+1 IF(IDHKK(I)/10000.EQ.7)NALLL=NALLL+1 IF(IDHKK(I)/10000.EQ.8)NALLL=NALLL+1 11667 CONTINUE C WRITE(6,*)' NALLL ',NALLL RETURN END * *===dentst=============================================================* * C PROGRAM DT_DENTST CDECK ID>, 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 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 * *===dfermi=============================================================* * CDECK ID>, DT_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 * *===dgamrn=============================================================* * CDECK ID>, DT_DGAMRN DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) ************************************************************************ * Sampling from Gamma-distribution. * * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * * Processed by S. Roesler, 6.5.95 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) NCOU = 0 N = INT(ETA) F = ETA-DBLE(N) IF (F.EQ.ZERO) GOTO 20 10 R = DT_RNDM(F) NCOU = NCOU+1 IF (NCOU.GE.11) GOTO 20 IF (R.LT.F/(F+2.71828D0)) GOTO 30 YYY = LOG(DT_RNDM(R)+TINY9)/F IF (ABS(YYY).GT.50.0D0) GOTO 20 Y = EXP(YYY) IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 GOTO 40 20 Y = 0.0D0 GOTO 50 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 40 IF (N.EQ.0) GOTO 70 50 Z = 1.0D0 DO 60 I = 1,N 60 Z = Z*DT_RNDM(Z) Y = Y-LOG(Z+TINY9) 70 DT_DGAMRN = Y/ALAM RETURN END * *===dhadde=============================================================* * CDECK ID>, DT_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 * *===dhadri=============================================================* * CDECK ID>, DT_DHADRI SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) 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---------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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.D+00/ 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 C IF(IPRI.GE.1) WRITE (6,1010) PLAB C STOP IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 C1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE C + 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 (LPRI.GT.4 .AND. 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 C C***IK IS THE REACTION CHANNEL C---------------------------- IF (VV.GT.WKK) GO TO 70 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 C IF (I1001.GT.50) GO TO 60 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 **sr 19.2.97: supress direct channel for pp-collisions IF (IT2.GT.0) GO TO 120 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 C C IIK IS THE DECAY CHANNEL C---------------------------- IF (VV.GT.WTI(IIK)) GO TO 180 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 C C FOR THE DECAY CHANNEL C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT C---------------------------- IF (AMS.GT.ECO) GO TO 190 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 C 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 * *===diagr==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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:MAXNCL),NWB(0:MAXNCL) 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,MAXNCL NWA(I) = 0 NWB(I) = 0 17 CONTINUE ENDIF ENDIF IF (NTARG.EQ.-1) THEN IF (NCOMPO.EQ.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_DIAGR: distribution of wounded nucleons' IF (LPRI.GT.4) & WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', & NCALL,NWAMAX,NWBMAX DO 18 I=1,MAX(NWAMAX,NWBMAX) IF (LPRI.GT.4) & 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.40).OR.((IJPROJ.GE.97).AND.(IJPROJ.LE.103)) & .OR.(IJPROJ.EQ.109).OR.(IJPROJ.EQ.115)).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 cdh WRITE(6,*) 'DT_DIAGR: XSHN call from here', IJPROJ 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) cdh if (LPRI.GT.4) write(LOUT,*)'DT_DIAGR: before 16' cdh 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 cdh if (LPRI.GT.4) write(LOUT,*)'DT_DIAGR: before loop 4' cdh 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 IF (LPRI.GT.4) & WRITE(LOUT,1001) MAXNCL 1001 FORMAT(1X, & 'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1000) JNT, MAXINT 1000 FORMAT(1X, & 'DT_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 cdh if (LPRI.GT.4) write(LOUT,*)'DT_DIAGR: NTRY= ',NTRY cdh 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 cdh if (LPRI.GT.4) write(LOUT,*)'DT_DIAGR: at end' cdh RETURN END * *===difevt=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, & OHALF=0.5D0) * event history PARAMETER (NMXHKK=250000) 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) XM,SDTOT,SIGIN 1000 FORMAT(1X,'DT_DIFEVT: single diffraction requested at E_cm = ', & E10.3,' 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 * *===difkin=============================================================* * CDECK ID>, DT_DIFFKI 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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, & IFUSION,IFLOW * 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 IF (LPRI.GT.4) . 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) XMTOT2 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) DEV1 1001 FORMAT(1X,'DT_DIFEVT: inconsitent Lorentz-transformation! ', & /,8X,4E12.3) GOTO 9999 ENDIF * select x-fractions in high-mass diff. interactions * select diffractive masses * - projectile IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) 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 IF (LPRI.GT.4) & WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT 1002 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1003) DEV1,DEV2 1003 FORMAT(1X,'DT_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 * *===difini=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===difput=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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(ONE).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(ONE).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 * *===diqbrk=============================================================* * CDECK ID>, DT_DIQBRK SUBROUTINE DT_DIQBRK IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * event history PARAMETER (NMXHKK=250000) 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 * *===dpoli==============================================================* * CDECK ID>, DT_DPOLI SUBROUTINE DT_DPOLI(CS,SI) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE U = DT_RNDM(CS) CS = DT_RNDM(U) IF (U.LT.0.5D0) CS=-CS SI = SQRT(1.0D0-CS*CS+1.0D-10) RETURN END * *===dsfecf=============================================================* * CDECK ID>, DT_DSFECF SUBROUTINE DT_DSFECF(SFE,CFE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) 1 CONTINUE X = DT_RNDM(SFE) Y = DT_RNDM(X) XX = X*X YY = Y*Y XY = XX+YY IF (XY.GT.ONE) GOTO 1 CFE = (XX-YY)/XY SFE = TWO*X*Y/XY IF (DT_RNDM(X).LT.OHALF) SFE = -SFE RETURN END * *===dsigin=============================================================* * CDECK ID>, DT_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 * *===dsigma_delta=======================================================* * CDECK ID>, DT_DSIGMA_DELTA DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) C----------------------------------------------------- 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----------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE 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 * *===dsqel_q2===========================================================* * CDECK ID>, DT_DSQEL_Q2 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) C------------------------------------------------------------------ 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 * *===dtchoi=============================================================* * CDECK ID>, DT_DTCHOI SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) C **************************** C TCHOIC CALCULATES A RANDOM VALUE C FOR THE FOUR-MOMENTUM-TRANSFER T C **************************** 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) * 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 * *===dthrep=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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, & IFUSION,IFLOW 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 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 IF(Y.GT.RHO) GO TO 1 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 IF (LPRI.GT.4) & WRITE(LOUT,*) & ' *** Threpd: energy/momentum conservation failure! ***', & EOCHCK,PXCHCK,PYCHCK,PZCHCK IF (LPRI.GT.4) & WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 ENDIF ** END IF RETURN END * *====dtrafo============================================================* * CDECK ID>, DT_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 * *===dtuini=============================================================* * CDECK ID>, DT_DTUINI SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, & IDP,IEMU) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 cdh WRITE(6,*)'DT_DTUINI before DT_INIT call' CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) CALL DT_STATIS(1) CALL PHO_PHIST(1000,DUM) IF (NCOMPO.LE.0) THEN CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) ELSE DO 1 I=1,NCOMPO CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) 1 CONTINUE ENDIF IF (IOGLB.NE.100) CALL DT_SIGEMU IEMU = IEMUL RETURN END * *===dtuout=============================================================* * CDECK ID>, DT_DTUOUT SUBROUTINE DT_DTUOUT IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE CALL PHO_PHIST(3000,DUM) CALL DT_STATIS(2) RETURN END * *===dtwopa=============================================================* * CDECK ID>, DT_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 * *===dtwopd=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) IF (UMO.LT.(AM1+AM2)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) UMO,AM1,AM2 1000 FORMAT(1X,'DT_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 * *===ebind==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & 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 * *===elhain=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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(*,*)'DT_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 ************************************************************************ * * * 3) Energy-momentum and quantum number conservation check routines * * * ************************************************************************ * *===emc1===============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) .AND. LPRI.GT.4) & 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 * *===emc2===============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) * event history PARAMETER (NMXHKK=250000) 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)) THEN CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) End If 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)) THEN CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) End If 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 * * *====eva2he============================================================* * * CDECK ID>, DT_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. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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) PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 SAVE / GENSTK / 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, JSPRES, JPTRES, & IEVAPL, IEVAPH, IEVPHO, IEVNEU, IEVPRO, IEVDEU, & IEVTRI, IEV3HE, IEV4HE, IDEEXG, IBTAR, ICHTAR, & IBLEFT, ICLEFT, ICHBLN, ICESTR, IBESTR, IOTHER, & KHYRES (IHYPMX), LRNFSS, LFRAGM SAVE / RESNUC / PARAMETER ( MXHEAV = 100 ) 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) SAVE / FHEAVY /, / FHEAVC / 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 * update counter IF (.NOT.LEVAPO) RETURN 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) ID,AM,AAM(ID) 1000 FORMAT(1X,'DT_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 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 (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) IF (IBTOT+IZTOT.NE.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT 1001 FORMAT(1X,'DT_EVA2HE: baryon-number/charge conservation ', & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) ENDIF RETURN END * *===eventa=============================================================* * CDECK ID>, DT_EVENTA SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) ************************************************************************ * Treatment of nucleon-nucleon interactions in a two-chain * * approximation. * * (input) ID BAMJET-index of projectile hadron (in case of * * h-K scattering) * * IP/IT mass number of projectile/target nucleus * * NCSY number of two chain systems * * IREJ rejection flag * * This version dated 15.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) IREJ = 0 NPOINT(3) = NHKK+1 * skip following treatment for low-mass diffraction IF (ABS(IFLAGD).EQ.1) THEN NPOINT(3) = NPOINT(2) GOTO 5 ENDIF * multiple scattering of chain ends IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) NC = NPOINT(2) * get a two-chain system from DTEVT1 DO 3 I=1,NCSY IFP1 = IDHKK(NC) IFT1 = IDHKK(NC+1) IFP2 = IDHKK(NC+2) IFT2 = IDHKK(NC+3) DO 4 K=1,4 PP1(K) = PHKK(K,NC) PT1(K) = PHKK(K,NC+1) PP2(K) = PHKK(K,NC+2) PT2(K) = PHKK(K,NC+3) 4 CONTINUE MOP1 = NC MOT1 = NC+1 MOP2 = NC+2 MOT2 = NC+3 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) IF (IREJ1.GT.0) THEN IRHHA = IRHHA+1 IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_EVENTA' GOTO 9999 ENDIF NC = NC+4 3 CONTINUE * meson/antibaryon projectile: * sample single-chain valence-valence systems (Reggeon contrib.) IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN IF (IIBAR(ID).LE.0) CALL DT_VV2SCH ENDIF IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN * check DTEVT1 for remaining resonance mass corrections CALL DT_EVTRES(IREJ1) IF (IREJ1.GT.0) THEN IRRES(1) = IRRES(1)+1 IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 2 in DT_EVENTA' GOTO 9999 ENDIF ENDIF * assign p_t to two-"chain" systems consisting of two resonances only * since only entries for chains will be affected, this is obsolete * in case of JETSET-fragmetation CALL DT_RESPT * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) IF (LCO2CR) CALL DT_COM2CR 5 CONTINUE * fragmentation of the complete event **uncomment for internal phojet-fragmentation C CALL DT_EVTFRA(IREJ1) CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) IF (IREJ1.GT.0) THEN IRFRAG = IRFRAG+1 IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 3 in DT_EVENTA' GOTO 9999 ENDIF * decay of possible resonances (should be obsolete) CALL DT_DECAY1 RETURN 9999 CONTINUE IREVT = IREVT+1 IREJ = 1 RETURN END C from dpm3304per 24.5.06 (j.r.) * *===eventb=============================================================* * CDECK ID>, DT_EVENTB SUBROUTINE DT_EVENTB(NCSY,IREJ) ************************************************************************ * Treatment of nucleon-nucleon interactions with full two-component * * Dual Parton Model. * * NCSY number of nucleon-nucleon interactions * * IREJ rejection flag * * This version dated 14.01.2000 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) C PYTHIA parameters INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) *! uncomment this line for internal phojet-fragmentation C #include "dtu_dtevtp.inc" * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG * properties of photon/lepton projectiles COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem COMMON /DTLTSU/ BGX,BGY,BGZ,GAM * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF * statistics: double-Pomeron exchange COMMON /DTFLG2/ INTFLG,IPOPO * flags for particle decays COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 * nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN C nucleon-nucleus / nucleus-nucleus interface to DPMJET INTEGER IDEQP,IDEQB,IHFLD,IHFLS DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) C model switches and parameters CHARACTER*8 MDLNA INTEGER ISWMDL,IPAMDL DOUBLE PRECISION PARMDL COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) C initial state parton radiation (internal part) INTEGER MXISR3,MXISR4 PARAMETER ( MXISR3 = 50, MXISR4 = 1000 ) INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), & IFL1(2,MXISR3),IFL2(2,MXISR3), & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC C event debugging information INTEGER NMAXD PARAMETER (NMAXD=100) INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD C general process information INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), & KPRON(15),ISINGL(10000) * initial values for max. number of phojet scatterings and dtunuc chains * to be fragmented with one pyexec call DATA MXPHFR,MXDTFR /10,100/ COMMON / DBGPRE / LDBGPR LOGICAL LDBGPR IREJ = 0 * pointer to first parton of the first chain in dtevt common NPOINT(3) = NHKK+1 * special flag for double-Pomeron statistics IPOPO = 1 * counter for low-mass (DTUNUC) interactions NDTUSC = 0 * counter for interactions treated by PHOJET NPHOSC = 0 * scan interactions for single nucleon-nucleon interactions * (this has to be checked here because Cronin modifies parton momenta) NC = NPOINT(2) IF (NCSY.GT.10000) THEN WRITE(LOUT,*) ' DT_EVENTB: NCSY > 10000 ! ' GOTO 9999 ENDIF 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 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB IN:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * multiple scattering of chain ends IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) * switch to PHOJET-settings for JETSET parameter IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) CALL DT_INITJS(1) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_EVENTB INITJS:',MKCRON,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * 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 XPSUB = 1.D0 XTSUB = 1.D0 * 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,4I6,(/,1P,4G23.15))') & ' DT_EVENTB MASHEL:',I,MOP,MOT,NHKK,PP,PT cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (IR1.NE.0) THEN IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,'(1X,A)') & 'DT_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 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB SETPAR-1:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB SETPAR-2:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * 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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,2I6,(/,1P,4G23.15))') & ' DT_EVENTB EVENT:',IREJ1,NHKK,PPNN,PTNN cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * 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 IF (LPRI.GT.4) & 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)') IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I4)') & 'DT_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 ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,2I6,(/,1P,4G23.15))') & ' DT_EVENTB GETPJE:',NPHOSC,NHKK,PPNN,PTNN cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (IREJ1.NE.0) THEN IF (IOULEV(1).GT.0 .AND. LPRI.GT.4) & WRITE(LOUT,'(1X,A,I4)') & 'DT_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 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB SETPAR-12:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB SETPAR-22:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * 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 * switch off qelast. vectormeson production for photons, * electrons and positrons - implemented to avoid final * state particles/resonances from Phojet with Id=81 IF (IJPROJ.EQ.7) THEN IPRON(3,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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,4I6,(/,1P,4G23.15))') & ' DT_EVENTB MASHEL:',I,MOP,MOT,NHKK,PPTMP,PTTMP cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,2I6,(/,1P,4G23.15))') & ' DT_EVENTB EVENT-2:',IREJ1,NHKK,PPTCMS,PTTCMS cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * 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 .AND. LPRI.GT.4) & WRITE(LOUT,'(1X,A)')'DT_EVENTB: chain system rejected' IF (LPRI.GT.4) & 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6,(/,1P,4G23.15))') WRITE (LOUT,'(A,2I6,(/,1P,4G23.15))') & ' DT_EVENTB GETPJE-2:',NPHOSC,NHKK,PP,PT cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (IREJ1.NE.0) THEN IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,'(1X,A,I4)') & 'DT_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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_EVENTB GETCSY:',IREJ1,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * check if this chain system was rejected IF (IREJ1.GT.0) THEN IF (IOULEV(1).GT.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,*) 'rejected 1 in DT_EVENTB' IF (LPRI.GT.4) & 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_EVENTB EVTRES:',IREJ1,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (IREJ1.GT.0) THEN IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) . WRITE(LOUT,*) 'rejected 2a in DT_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 DT_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 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' EVENTB DIQBRK:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF MXLEFT = 4 ENDIF C chain fusion C WRITE(6,*)' EVENTB: IFUSION before DENSITY,IAPROJ,IATARG', C * IFUSION,IP,IT IF((IFUSION.EQ.1).AND.(IP.GT.12).AND. (IT.GT.12)) CALL DT_DENSITY IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_EVENTB DENSITY:',IFUSION,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * * IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_EVENTB BEF HADRONIZATION:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF *----------------------------------------------------------------------- * 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 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,5I6)') WRITE (LOUT,'(A,5I6)') & ' DT_EVENTB AFTER PHOJET HADR.:', & NPJE,NPHOSC,NPYMEM,NPYMAX,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * * 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,*) ' DT_EVENTB: Mxphfr reduced to ',MXPHFR ENDIF * * hadronize DTUNUC chain systems 23 CONTINUE IBACK = MXDTFR CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6)') WRITE (LOUT,'(A,4I6)') & ' DT_EVENTB AFTER DTUNUC HADR.:', & IBACK,NPYMEM,IREJ2,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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,*) ' DT_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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_EVENTB' IRFRAG = IRFRAG+1 GOTO 9999 ENDIF C from dpm3304per 24.5.06 (j.r.) C j.r.12/01 Fragmentation of fused chains C 1 change PYTHIA Parameters PARRJ21=PARJ(21) PARRJ23=PARJ(23) PARRJ24=PARJ(24) PARRJ41=PARJ(41) PARRJ42=PARJ(42) C temporarily standard parameters j.r.5/02 C PARJ(21)=1.08D0 C PARJ(23)=0.2D0 C PARJ(24)=2.D0 PARJ(41)=0.15D0 C old before 7.11.6: to be kept if pyptdi is kept the old one: PARJ(42)=1.3D0 C new: only if pyptdi is the new one C PARJ(42)=0.40D0 IESSS1=IESSS1+1 C IF(IESSS1.LT.3 .AND. LPRI.GT.4) C * WRITE(LOUT,*) C * '1 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)', C * PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42) C IF(IESSS1.LT.3 .AND. LPRI.GT.4) C * WRITE(LOUT,*) C * '1 PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3)', C * PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3) C IF(IESSS1.LT.3 .AND. LPRI.GT.4) C * WRITE(LOUT,*)'1 PARJ(5),PARJ(19)', C * PARJ(5),PARJ(19) 223 CONTINUE IBACK = MXDTFR C IBACK = 10 C IBACK=1 IBACK=50 CALL DT_EVTFRG2(2,IBACK,NPYMEM,IREJ2) C WRITE(6,*)'PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)', C * PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42) C WRITE(6,*)'DT_EVTFRG2(2,IBACK,NPYMEM,IREJ2) ',IBACK,NPYMEM,IREJ2 IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6)') WRITE (LOUT,'(A,4I6)') & ' DT_EVENTB AFTER FUSION HADR.:', & IBACK,NPYMEM,IREJ2,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (IREJ2.GT.0) GOTO 222 * 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,*) ' DT_EVENTB: Mxdtfr reduced to ',MXDTFR ENDIF IF (IBACK.EQ.-1) GOTO 223 C 2 Return to PYTHIA default parameters 222 CONTINUE PARJ(21)=PARRJ21 PARJ(23)=PARRJ23 PARJ(24)=PARRJ24 PARJ(41)=PARRJ41 PARJ(42)=PARRJ42 IESSS2=IESSS2+1 C IF(IESSS2.LT.3) C *WRITE(6,*)' 2 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)', C * PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42) C IF(IESSS2.LT.3) C * WRITE(6,*)'2 PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3)', C * PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3) C IF(IESSS2.LT.3) C * WRITE(6,*)'2 PARJ(5),PARJ(19)', C * PARJ(5),PARJ(19) * C from dpm3304per 24.5.06 (j.r.) * * 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 * *===eventd=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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, & IFUSION,IFLOW INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ * 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 ' DT_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 * *===evtchg=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') & 'DT_EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK CALL PHO_PREVNT(2) CALL DT_EVTOUT(1) 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)')'DT_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 * *===evtemc=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, & ZERO=0.0D0) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW 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 (LPRI.GT.4 .AND. IOULEV(2).GT.0) & WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') & 'DT_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 * *===evtflc=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10) IREJ = 0 IF (MODE.EQ.3) THEN IF (IFL.NE.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I3,A,I3)') & 'DT_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 * *===evtfrg=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) PARAMETER (ONE=1.0D0,ZERO=0.0D0) LOGICAL LACCEP PARAMETER (MXJOIN=400) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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 INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ INTEGER PYK DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) COMMON / DBGPRE / LDBGPR LOGICAL LDBGPR IF ( LDBGPR ) THEN cdh WRITE (77,*) WRITE (LOUT,*) cdh WRITE (77,'(A,5I6)') WRITE (LOUT,'(A,5I6)') & ' DT_EVTFRG IN:',KMODE,NFRG,NPYMEM,IREJ,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,6I6)') WRITE (LOUT,'(A,6I6)') & ' DT_EVTFRG LACCEP:',I,NPOINT(3),NPOINT(4),IDCHK,ISTSRG,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6)') WRITE (LOUT,'(A,4I6)') & ' DT_EVTFRG NO GOTO 16:',IDRES(I),IFRG,NFRG,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6,/,1P,4G23.15)') WRITE (LOUT,'(A,4I6,/,1P,4G23.15)') & ' DT_EVTFRG EVTEMC:',I,IDHKK(I),INIEMC,NHKK, & (PHKK(IJK,I),IJK=1,4) cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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) THEN WRITE(6,*) 'ISH > MXJOIN !' GOTO 9999 END IF 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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6,/,1P,4G23.15)') WRITE (LOUT,'(A,4I6,/,1P,4G23.15)') & ' DT_EVTFRG EVTEMC-2:',KK,IDHKK(KK),INIEMC,NHKK, & (PHKK(IJK,KK),IJK=1,4) cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,4I6)') WRITE (LOUT,'(A,4I6)') & ' DT_EVTFRG EVTFLC:',KK,IDHKK(KK),INIEMC,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 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) THEN WRITE(6,*) 'ISH > MXJOIN !' GOTO 9999 END IF ISJOIN(ISH) = KK ENDIF IJ = IJ+1 IF (IJ.GT.MXJOIN) THEN WRITE(6,*) 'IJ > MXJOIN !' GOTO 9999 END IF IJOIN(IJ) = IP IHISMO(IP) = I 11 CONTINUE N = IP * join the two-parton system CALL PYJOIN(IJ,IJOIN) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' EVTFRG PYJOIN:',IJ,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6,1P,G23.15)') WRITE (LOUT,'(A,2I6,1P,G23.15)') & ' EVTFRG PYSHOW:',IH1,IH2,RQLUN cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF ISJOIN(K1) = 0 ISJOIN(K2) = 0 GOTO 130 ENDIF 135 CONTINUE 130 CONTINUE ENDIF ENDIF 136 CONTINUE CALL DT_INITJS(MODE) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' EVTFRG INITJS:',MODE,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * hadronization CALL PYEXEC IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' EVTFRG PYEXEC:',MSTU(24),NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF IF (MSTU(24).NE.0) THEN IF (LPRI.GT.4) . 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 ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' EVTFRG 13:',NLINES,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 * * *===evtfrg2=============================================================* * CDECK ID>, DT_EVTFRG2 SUBROUTINE DT_EVTFRG2(KMODE,NFRG,NPYMEM,IREJ) ************************************************************************ * Hadronization of chains in DTEVT1. * * * * Input: * * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * * = 2 hadronization of DTUNUC-chains (id=66xxx) * * 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 (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) PARAMETER (ONE=1.0D0,ZERO=0.0D0) LOGICAL LACCEP PARAMETER (MXJOIN=300) COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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 INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ INTEGER PYK DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) DATA IESSS1,IESSS2,IESSS4,IESSS5,IESSS6,IESSS7,IESSS8,IESSS9 * /0,0,0,0,0,0,0,0/ MODE = KMODE ISTSTG = 7 IF (MODE.NE.1) ISTSTG = 6 IREJ = 0 IP = 0 ISH = 0 INIEMC = 1 NEND = NHKK NACCEP = 0 IFRG = 0 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 C WRITE(6,*)' NPOINT 3,4,NEND ',NPOINT(3),NPOINT(4),NEND C WRITE(6,*)'ISTSTG ',ISTSTG 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 ELSEIF(IDCHK.EQ.6) THEN IPJE = 1 IFRG = IFRG+1 C WRITE(6,*)'I, IDCHK,IFRG,NFRG' C * ,I, IDCHK,IFRG,NFRG,IDHKK(I) 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) THEN WRITE(6,*) 'ISH > MXJOIN !' GOTO 9999 END IF 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 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) THEN WRITE(6,*) 'ISH > MXJOIN !' GOTO 9999 END IF ISJOIN(ISH) = KK ENDIF IJ = IJ+1 IF (IJ.GT.MXJOIN) THEN WRITE(6,*) 'IJ > MXJOIN !' GOTO 9999 END IF IJOIN(IJ) = IP IHISMO(IP) = I 11 CONTINUE N = IP * join the two-parton system C CALL PYLIST(2) 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) C j.r.12/01 Fragmentation of fused chains PARRJ21=PARJ(21) PARRJ23=PARJ(23) PARRJ24=PARJ(24) PARRJ41=PARJ(41) PARRJ42=PARJ(42) C temporarily standard parameters j.r.5/02 C PARJ(21)=1.08D0 C PARJ(23)=0.2D0 C PARJ(24)=2.D0 PARJ(41)=0.15D0 PARJ(42)=1.3D0 IESSS3=IESSS3+1 C IF(IESSS3.LT.3) C *WRITE(6,*)' 3 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)', C * PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42) C * WRITE(6,*)'3 PARJ(5),PARJ(19)', C * PARJ(5),PARJ(19) * hadronization CALL PYEXEC C CALL PYLIST(2) 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 * * *===evthis=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LNOETY PARAMETER (ZERO = 0.0D0, & ONE = 1.0D0, & TINY = 1.0D-10) * histograms PARAMETER (NHIS=10, 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 * *===evtini=============================================================* * CDECK ID>, DT_EVTINI SUBROUTINE DT_EVTINI ************************************************************************ * Initialization of DTEVT1. * * This version dated 15.01.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL * initialization of DTEVT1/DTEVT2 NEND = NHKK IF (NEVENT.EQ.1) NEND = NMXHKK NHKK = 0 NEVHKK = NEVENT DO 1 I=1,NEND ISTHKK(I) = 0 IDHKK(I) = 0 JMOHKK(1,I) = 0 JMOHKK(2,I) = 0 JDAHKK(1,I) = 0 JDAHKK(2,I) = 0 IDRES(I) = 0 IDXRES(I) = 0 NOBAM(I) = 0 IDCH(I) = 0 IHIST(1,I) = 0 IHIST(2,I) = 0 DO 2 J=1,4 PHKK(J,I) = 0.0D0 VHKK(J,I) = 0.0D0 WHKK(J,I) = 0.0D0 2 CONTINUE PHKK(5,I) = 0.0D0 1 CONTINUE DO 3 I=1,10 NPOINT(I) = 0 3 CONTINUE CALL DT_CHASTA(-1) C* initialization of DTLTRA C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) RETURN END * *===evtout=============================================================* * CDECK ID>, DT_EVTOUT SUBROUTINE DT_EVTOUT(MODE) ************************************************************************ * MODE = 1 plot content of complete DTEVT1 to out. unit * * 3 plot entries of extended DTEVT1 (DTEVT2) * * 4 plot entries of DTEVT1 and DTEVT2 * * This version dated 11.12.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) DIMENSION IRANGE(NMXHKK) IF (MODE.EQ.2) RETURN CALL DT_EVTPLO(IRANGE,MODE) RETURN END * *===evtplo=============================================================* * CDECK ID>, DT_EVTPLO SUBROUTINE DT_EVTPLO(IRANGE,MODE) ************************************************************************ * MODE = 1 plot content of complete DTEVT1 to out. unit * * 2 plot entries of DTEVT1 given by IRANGE * * 3 plot entries of extended DTEVT1 (DTEVT2) * * 4 plot entries of DTEVT1 and DTEVT2 * * 5 plot rejection counter * * This version dated 11.12.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI CHARACTER*16 CHAU * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC DIMENSION IRANGE(NMXHKK) IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_EVTPLO:',14X,' content of COMMON /DTEVT1/',/, & 15X,' --------------------------',/,/, & ' ST ID M1 M2 D1 D2 PX PY', & ' PZ E M',/) DO 1 I=1,NHKK IF (LPRI.GT.4) & WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), & PHKK(5,I) C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), C & PHKK(3,I),PHKK(4,I) C WRITE(LOUT,'(4E15.4)') C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) 1001 FORMAT(I5,I5,I6,4I5,3F12.3,F12.3,F8.4) C1011 FORMAT(I5,I5,I6,4I5,2E15.5) 1 CONTINUE IF (LPRI.GT.4) & WRITE(LOUT,*) C DO 4 I=1,NHKK C WRITE(LOUT,1006) I,ISTHKK(I), C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), C & WHKK(2,I),WHKK(3,I) C1006 FORMAT(1X,I4,I6,6E10.3) C 4 CONTINUE ENDIF IF (MODE.EQ.2) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) NC = 0 2 CONTINUE NC = NC+1 IF (IRANGE(NC).EQ.-100) GOTO 9999 I = IRANGE(NC) IF (LPRI.GT.4) & WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), & PHKK(5,I) GOTO 2 ENDIF IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1002) 1002 FORMAT(/,1X,'DT_EVTPLO:',14X, & ' content of COMMON /DTEVT1/,/DTEVT2/',/, & 15X,' -----------------------------------',/,/, & ' ST ID M1 M2 D1 D2 IDR IDXR', & ' NOBAM IDCH M',/) DO 3 I=1,NHKK C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN KF = IDHKK(I) IDCHK = KF/10000 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 CALL PYNAME(KF,CHAU) IF (LPRI.GT.4) & WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), & PHKK(5,I),CHAU 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) C ENDIF 3 CONTINUE ENDIF IF (MODE.EQ.5) THEN *af: 2 lines just to make the compiler happy IREMC = 0 IRSEA = 0 IF (LPRI.GT.4) & WRITE(LOUT,1004) 1004 FORMAT(/,1X,'DT_EVTPLO:',14X,' content of COMMON /DTREJC/',/, & 15X,' --------------------------',/) IF (LPRI.GT.4) & WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, & IRSEA,IRCRON 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, & 1X,'IREMC = ',10I5,/, & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) ENDIF 9999 RETURN END * *===evtput=============================================================* * CDECK ID>, DT_EVTPUT SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) C IF (MODE.GT.100) THEN C WRITE(LOUT,'(1X,A,I5,A,I5)') C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 C NHKK = NHKK-MODE+100 C RETURN C ENDIF MO1 = M1 MO2 = M2 NHKK = NHKK+1 IF (NHKK.GT.NMXHKK) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) NHKK 1000 FORMAT(1X,'DT_EVTPUT: NHKK exeeds NMXHKK = ',I7, & '! program execution stopped..') STOP ENDIF IF (M1.LT.0) MO1 = NHKK+M1 IF (M2.LT.0) MO2 = NHKK+M2 ISTHKK(NHKK) = IST IDHKK(NHKK) = ID JMOHKK(1,NHKK) = MO1 JMOHKK(2,NHKK) = MO2 JDAHKK(1,NHKK) = 0 JDAHKK(2,NHKK) = 0 IDRES(NHKK) = IDR IDXRES(NHKK) = IDXR IDCH(NHKK) = IDC ** here we need to do something.. IF (ID.EQ.88888) THEN IDMO1 = ABS(IDHKK(MO1)) IDMO2 = ABS(IDHKK(MO2)) IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 ELSE NOBAM(NHKK) = 0 ENDIF IDBAM(NHKK) = IDT_ICIHAD(ID) IF (MO1.GT.0) THEN IF (JDAHKK(1,MO1).NE.0) THEN JDAHKK(2,MO1) = NHKK ELSE JDAHKK(1,MO1) = NHKK ENDIF ENDIF IF (MO2.GT.0) THEN IF (JDAHKK(1,MO2).NE.0) THEN JDAHKK(2,MO2) = NHKK ELSE JDAHKK(1,MO2) = NHKK ENDIF ENDIF C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN C PTOT = SQRT(PX**2+PY**2+PZ**2) C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) C AMRQ = AAM(IDBAM(NHKK)) C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. C & (PTOT.GT.ZERO)) THEN C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) C E = E+DELTA C PTOT1 = PTOT-DELTA C PX = PX*PTOT1/PTOT C PY = PY*PTOT1/PTOT C PZ = PZ*PTOT1/PTOT C ENDIF C ENDIF PHKK(1,NHKK) = PX PHKK(2,NHKK) = PY PHKK(3,NHKK) = PZ PHKK(4,NHKK) = E PTOT = SQRT( PX**2+PY**2+PZ**2 ) IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) ELSE PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) C & WRITE(LOUT,'(1X,A,G10.3)') C & 'DT_EVTPUT: negative mass**2 ',PHKK(5,NHKK) PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) ENDIF IDCHK = ID/10000 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN * special treatment for chains: * z coordinate of chain in Lab = pos. of target nucleon * time of chain-creation in Lab = time of passage of projectile * nucleus at pos. of taget nucleus C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) VHKK(1,NHKK) = VHKK(1,MO2) VHKK(2,NHKK) = VHKK(2,MO2) VHKK(3,NHKK) = VHKK(3,MO2) VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) WHKK(1,NHKK) = WHKK(1,MO1) WHKK(2,NHKK) = WHKK(2,MO1) WHKK(3,NHKK) = WHKK(3,MO1) WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB ELSE IF (MO1.GT.0) THEN DO 1 I=1,4 VHKK(I,NHKK) = VHKK(I,MO1) WHKK(I,NHKK) = WHKK(I,MO1) 1 CONTINUE ELSE DO 2 I=1,4 VHKK(I,NHKK) = ZERO WHKK(I,NHKK) = ZERO 2 CONTINUE ENDIF ENDIF RETURN END * *===evtres=============================================================* * CDECK ID>, DT_EVTRES SUBROUTINE DT_EVTRES(IREJ) ************************************************************************ * This version dated 14.12.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) IREJ = 0 DO 1 I=NPOINT(3),NHKK IF (ABS(IDRES(I)).GE.100) THEN AMMX = 0.0D0 DO 2 J=NPOINT(3),NHKK IF (IDHKK(J).EQ.88888) THEN IF (PHKK(5,J).GT.AMMX) THEN AMMX = PHKK(5,J) IMMX = J ENDIF ENDIF 2 CONTINUE IF (IDRES(IMMX).NE.0) THEN IF (IOULEV(3).GT.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') & 'DT_EVTRES: no chain for correc. found' C GOTO 6 GOTO 9999 ELSE GOTO 9999 ENDIF ENDIF IMO11 = JMOHKK(1,I) IMO12 = JMOHKK(2,I) IF (PHKK(3,IMO11).LT.0.0D0) THEN IMO11 = JMOHKK(2,I) IMO12 = JMOHKK(1,I) ENDIF IMO21 = JMOHKK(1,IMMX) IMO22 = JMOHKK(2,IMMX) IF (PHKK(3,IMO21).LT.0.0D0) THEN IMO21 = JMOHKK(2,IMMX) IMO22 = JMOHKK(1,IMMX) ENDIF AMCH1 = PHKK(5,I) AMCH1N = AAM(IDXRES(I)) IFPR1 = IDHKK(IMO11) IFPR2 = IDHKK(IMO21) IFTA1 = IDHKK(IMO12) IFTA2 = IDHKK(IMO22) DO 4 J=1,4 PP1(J) = PHKK(J,IMO11) PP2(J) = PHKK(J,IMO21) PT1(J) = PHKK(J,IMO12) PT2(J) = PHKK(J,IMO22) 4 CONTINUE * store initial configuration for energy-momentum cons. check * correct kinematics of second chain IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, & AMCH1,AMCH1N,AMCH2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 * check now this chain for resonance mass IFP(1) = IDT_IPDG2B(IFPR2,1,2) IFP(2) = 0 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) IFT(1) = IDT_IPDG2B(IFTA2,1,2) IFT(2) = 0 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) IDCH2 = 2 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, & AMCH2,AMCH2N,IDCH2,IREJ1) IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN IF (IOULEV(1).GT.0 .AND. LPRI.GT.4) & WRITE(LOUT,*) ' correction for resonance not poss.' **sr test C GOTO 1 C GOTO 9999 ** ENDIF * store final configuration for energy-momentum cons. check IF (LEMCCK) THEN CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) IF (IREJ1.NE.0) GOTO 9999 ENDIF DO 5 J=1,4 PHKK(J,IMO11) = PP1(J) PHKK(J,IMO21) = PP2(J) PHKK(J,IMO12) = PT1(J) PHKK(J,IMO22) = PT2(J) 5 CONTINUE * correct entries of chains DO 3 K=1,4 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) 3 CONTINUE AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- & PHKK(3,IMMX)**2 * ?? the following should now be obsolete **sr test C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN ** IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,4G10.3)') & 'DT_EVTRES: inonsistent mass-corr.',AM1,AM2 C GOTO 9999 GOTO 1 ENDIF PHKK(5,I) = SQRT(AM1) PHKK(5,IMMX) = SQRT(AM2) IDRES(I) = IDRES(I)/100 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,4G10.3)') & 'DT_EVTRES: inconsistent chain-masses', & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 GOTO 9999 ENDIF ENDIF 1 CONTINUE C 6 CONTINUE RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===fer4m==============================================================* * CDECK ID>, DT_FER4M SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) ************************************************************************ * Sampling of nucleon Fermi-momenta from distributions at T=0. * * processed by S. Roesler, 17.10.95 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LSTART * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * nuclear potential LOGICAL LFERMI COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, & EBINDP(2),EBINDN(2),EPOT(2,210), & ETACOU(2),ICOUL,LFERMI DATA LSTART /.TRUE./ ILOOP = 0 IF (LFERMI) THEN IF (LSTART) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_FER4M: sampling of Fermi-momenta activated') LSTART = .FALSE. ENDIF C 1 CONTINUE CALL DT_DFERMI(PABS) PABS = PFERM*PABS C IF (PABS.GE.PBIND) THEN C ILOOP = ILOOP+1 C IF (MOD(ILOOP,500).EQ.0) THEN C WRITE(LOUT,1001) PABS,PBIND,ILOOP C1001 FORMAT(1X,'DT_FER4M: Fermi-mom. corr. for binding', C & ' energy ',2E12.3,I6) C ENDIF C GOTO 1 C ENDIF CALL DT_DPOLI(POLC,POLS) CALL DT_DSFECF(SFE,CFE) CXTA = POLS*CFE CYTA = POLS*SFE CZTA = POLC ET = SQRT(PABS*PABS+AAM(KT)**2) PXT = CXTA*PABS PYT = CYTA*PABS PZT = CZTA*PABS ELSE ET = AAM(KT) PXT = 0.0D+00 PYT = 0.0D+00 PZT = 0.0D+00 ENDIF RETURN END * *===ficonf=============================================================* * CDECK ID>, DT_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. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) PARAMETER (ANGLGB=5.0D-16) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 SAVE / GENSTK / 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, JSPRES, JPTRES, & IEVAPL, IEVAPH, IEVPHO, IEVNEU, IEVPRO, IEVDEU, & IEVTRI, IEV3HE, IEV4HE, IDEEXG, IBTAR, ICHTAR, & IBLEFT, ICLEFT, ICHBLN, ICESTR, IBESTR, IOTHER, & KHYRES (IHYPMX), LRNFSS, LFRAGM SAVE / RESNUC / 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 ) PARAMETER ( AMUAMU = AMUGEV ) PARAMETER ( AMPROT = AMPRTN ) PARAMETER ( AMNEUT = AMNTRN ) 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 ) PARAMETER ( GAMMIN = 1.0D-06 ) PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), & EFRMAV (2), AMNUCL (3), AMNUSQ (3), 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:130) SAVE / NUCDAT / 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 SAVE / PAREVT / PARAMETER ( MXHEAV = 100 ) 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) SAVE / FHEAVY /, / FHEAVC / * 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 EXTERNAL EXMSAZ EXTERNAL PFRMAV 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.-100).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,'DT_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)) IF (AMRCL(I).LE.ZERO) THEN IF (IOULEV(3).GT.0 .AND. LPRI.GT.4) & 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 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) & THEN **sr C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I) ** **sr 3.3 C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) M = MIN(NTOT(I),260) IF (NEXC(I,M).GT.0) THEN AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) c WRITE(77,*)' EXC(I,M),NEXC(I,M),M,I', c & EXC(I,M),NEXC(I,M),M,I ELSE 70 CONTINUE M = M+1 IF (M.GE.INUC(I)) THEN * A.F. * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) IF ( INUC (I) .GT. NTOT (I) ) THEN AMRCL(I) = AMRCL0(I) & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) c WRITE(77,*)' EXPNUC(I),NTOT(I),M,INUC(I)', c & EXPNUC(I),NTOT(I),M,INUC(I) 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)) c WRITE(77,*)' 2:EXC(I,M),NEXC(I,M),M,I', c & EXC(I,M),NEXC(I,M),M,I ELSE GOTO 70 ENDIF ENDIF ENDIF ** EEXC(I) = AMRCL(I)-AMRCL0(I) c WRITE(77,*)' ICOR,EEXC(I),AMRCL0(I)', c & ICOR,EEXC(I),AMRCL0(I) ICOR = ICOR+I ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN IF (IOULEV(3).GT.0 .AND. LPRI.GT.4) & 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 ELSE * excitation energies of residual nuclei EEXC (I) = AMRCL(I)-AMRCL0(I) * === A.F. === * LLCPOT = .TRUE. ILCOPT = 3 IF ( LLCPOT ) THEN NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) IF ( ILCOPT .LE. 2 ) THEN * Patch for Fermi momentum reduction correlated with impact parameter: FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) AKPRHO = ONE - DLKPRH * f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, & 0.05D+00 ) * REDORI = 0.75D+00 * REDORI = ONE 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 c WRITE(77,*)' PRSKIN,FRCFLL',PRSKIN,FRCFLL REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) END IF IF ( NNCHIT .GT. 0 ) THEN IF ( ILCOPT .EQ. 1 ) THEN SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) DO 1220 NCH = 1, 10 ETAETA = ( ONE - SKINRH**INUC(I) & - DBLE(INUC(I))* ( ONE - FRCFLL ) & * ( ONE - SKINRH ) ) & / ( SKINRH**INUC(I) - DBLE (INUC(I)) & * ( ONE - FRCFLL) * SKINRH ) SKINRH = SKINRH * ( ONE + ETAETA ) c WRITE(77,*) c & ' SKINRH,NCH,INUC(I),FRCFLL,FRMRDC,APFRMX', c & SKINRH,NCH,INUC(I),FRCFLL,FRMRDC,APFRMX 1220 CONTINUE PRSKIN = SKINRH**(NNCHIT-1) ELSE IF ( ILCOPT .EQ. 2 ) THEN PRSKIN = ONE - FRCFLL 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 * === End A.F. === * IF (ICASCA.EQ.0) THEN **sr 15.1. C EXPNUC(I) = EEXC(I)/DBLE(NTOT(I)) 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 IF (LPRI.GT.4) & WRITE(LOUT,1003) I 1003 FORMAT(1X,'DT_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 IF (LPRI.GT.4) . 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 .AND. LPRI.GT.4) & 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,'DT_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 * !!!!!!!! Aarghh !!!!!!!! This is a major crime, it spoils FLUKA!!! * NP = 0 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) cdh & WRITE(77,*)' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', & 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 IF (LPRI.GT.4) & 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) C**af added to replace amnama from original DPMJET AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(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 * evaporation WE = ONE * movd from above NP = 0 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 * *===filhgr=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO = 0.0D0, & ONE = 1.0D0, & TINY = 1.0D-10) * histograms PARAMETER (NHIS=10, 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 C1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, C & ' 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 IF (LPRI.GT.4) & WRITE(LOUT,1001) 1001 FORMAT(1X,'DT_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 * *===flahad=============================================================* * CDECK ID>, DT_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 * * - all ID are accepted. ID above 39 taken from PHOJET * * 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) DOUBLE PRECISION xm_list,tau_list,gam_list, & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list, & xm_bb82_list,xm_bb102_list INTEGER ich3_list,iba3_list,iq_list, & id_psm_list,id_vem_list,id_b8_list,id_b10_list COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300), & xm_psm2_list(6,6),xm_vem2_list(6,6), & xm_b82_list(6,6,6),xm_b102_list(6,6,6), & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6), & ich3_list(300),iba3_list(300),iq_list(3,300), & id_psm_list(6,6),id_vem_list(6,6), & id_b8_list(6,6,6),id_b10_list(6,6,6) DIMENSION JSEL(3,6) DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ DIMENSION IPOQUA(3) 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)) IF (ID.LE.39) THEN IF1 = MQUARK(JSEL(1,IX),ID) IF2 = MQUARK(JSEL(2,IX),ID) IF3 = MQUARK(JSEL(3,IX),ID) * Use PHOJET quark tables if BAMJET id exceeds 39 (limit of MQUARK) ELSE IDPDG = IDT_IPDGHA(ID) c WRITE(6,*) 'DT_FLAHAD: ID, IDPDG', ID, IDPDG IDCPC = IPHO_PDG2ID(IDPDG) DO IQ=1,3 IPOQUA(IQ) = IQ_LIST(IQ,abs(IDCPC)) IPOQUA(IQ) = SIGN(IPOQUA(IQ),IDCPC) * Swap u and d quarks to convert from PHOJET to DPMJET IF (ABS(IPOQUA(IQ)).EQ.1) THEN IPOQUA(IQ) = SIGN(2, IPOQUA(IQ)) ELSEIF (ABS(IPOQUA(IQ)).EQ.2) THEN IPOQUA(IQ) = SIGN(1, IPOQUA(IQ)) ENDIF END DO c WRITE(6,*) 'DT_FLAHAD: ID, IPOQUA', ID, IPOQUA IF1 = IPOQUA(JSEL(1,IX)) IF2 = IPOQUA(JSEL(2,IX)) IF3 = IPOQUA(JSEL(3,IX)) ENDIF c WRITE(6,*) 'DT_FLAHAD: ID, IF1, IF2, IF3', ID,IF1,IF2,IF3 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 * *===fluini=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) IF (LPRI.GT.4) &WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_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 * *===fozoca=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD 1000 FORMAT(/,1X,'DT_FOZOCA: intranuclear cascade treated for a ', & 'maximum of',I4,' generations',/,10X,'formation time ', & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) IF (LPRI.GT.4 .AND. ITAUVE.EQ.1) & WRITE(LOUT,1001) IF (LPRI.GT.4 .AND. 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 C================================================================== C. Generation of Delta resonance events C================================================================== * *===gen_delta==========================================================* * CDECK ID>, DT_GEN_DELTA SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) C---------------------------------------------------- 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---------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ **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.231D+00/, GAMD /0.12D+00/, DELD/0.169D+00/, & AMDMIN/1.084D+00/ DATA AMN /0.93827231D+00, 0.93956563D+00/ DATA AML0 /2*0.51100D-03,2*0.105659D+00, 2*1.777D+00/ c WRITE(6,*)' DT_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.D+00 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.D+00 P(1,4) = ENU P(1,1) = 0.D+00 P(1,2) = 0.D+00 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.D+00 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.D+00 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 CONTINUE R = PYR(0) AMD=AMD0+0.5D+00*GAMD*TAN((2.D+00*R-1.D+00) & *ATAN(2.D+00*DELD/GAMD)) NTRY = NTRY + 1 IF (NTRY .GT. 1000) THEN LBAD = 1 *af: 1 line, make the compiler happy NBAD = 0 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.D+00*AMN(LTARG)) IF (ENUU .LT. ET) GOTO 100 C...Kinematical limits in Q**2 S = AMN(LTARG)**2 + 2.D+00*AMN(LTARG)*ENUU SQS = SQRT(S) PSTAR = (S - AMN(LTARG)**2)/(2.D+00*SQS) ELF = (S - AMD**2 + AML2)/(2.D+00*SQS) PLF = SQRT(ELF**2 - AML2) Q2MIN = -AML2 + 2.D+00*PSTAR*(ELF-PLF) Q2MAX = -AML2 + 2.D+00*PSTAR*(ELF+PLF) IF (Q2MIN .LT. 0.D+00) Q2MIN = 0.D+00 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.D+00*SQS) GAM = EISTAR/AMN(LTARG) BET = PSTAR/EISTAR CTSTAR = ELF/PLF - (Q2 + AML2)/(2.D+00*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.28319D+00*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.D+00 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.D+00 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 C================================================================== C Generation of a Quasi-Elastic neutrino scattering C================================================================== * *===gen_qel============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ * 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. ! mass P(1,4) = ENU0 ! energy 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 *af: 1 line, make the compiler happy NBAD = 0 IF (LPRI.GT.4) & 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' c******************************************** IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) 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 * *===getbin=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO = 0.0D0, & ONE = 1.0D0, & TINY35 = 1.0D-35) * histograms PARAMETER (NHIS=10, 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 * *===getbxs=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 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 * *===getcsy=============================================================* * CDECK ID>, DT_GETCSY SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, ************************************************************************ * This version dated 15.01.95 is written by S. Roesler * ************************************************************************ & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) IREJ = 0 * get quark content of partons DO 1 I=1,2 IFP1(I) = 0 IFP2(I) = 0 IFT1(I) = 0 IFT2(I) = 0 1 CONTINUE IFP1(1) = IDT_IPDG2B(IFPR1,1,2) IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) IFP2(1) = IDT_IPDG2B(IFPR2,1,2) IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) IFT1(1) = IDT_IPDG2B(IFTA1,1,2) IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) IFT2(1) = IDT_IPDG2B(IFTA2,1,2) IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) IDCH1 = 2 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 IDCH2 = 2 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 * store initial configuration for energy-momentum cons. check * sample intrinsic p_t at chain-ends IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) IF (IREJ1.NE.0) THEN IF (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_GETCSY' IRPT = IRPT+1 GOTO 9999 ENDIF C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN C* check second chain for resonance C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, C & AMCH2,AMCH2N,IDCH2,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C IF (IDR2.NE.0) THEN C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, C & AMCH2,AMCH2N,AMCH1,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C ENDIF C* check first chain for resonance C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, C & AMCH1,AMCH1N,IDCH1,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C IF (IDR1.NE.0) IDR1 = 100*IDR1 C ELSE C* check first chain for resonance C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, C & AMCH1,AMCH1N,IDCH1,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C IF (IDR1.NE.0) THEN C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, C & AMCH1,AMCH1N,AMCH2,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C ENDIF C* check second chain for resonance C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, C & AMCH2,AMCH2N,IDCH2,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 C IF (IDR2.NE.0) IDR2 = 100*IDR2 C ENDIF C ENDIF IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN * check chains for resonances CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, & AMCH1,AMCH1N,IDCH1,IREJ1) IF (IREJ1.NE.0) GOTO 9999 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, & AMCH2,AMCH2N,IDCH2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 * change kinematics corresponding to resonance-masses IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, & AMCH1,AMCH1N,AMCH2,IREJ1) IF (IREJ1.GT.0) GOTO 9999 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, & AMCH2,AMCH2N,IDCH2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 IF (IDR2.NE.0) IDR2 = 100*IDR2 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, & AMCH2,AMCH2N,AMCH1,IREJ1) IF (IREJ1.GT.0) GOTO 9999 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, & AMCH1,AMCH1N,IDCH1,IREJ1) IF (IREJ1.NE.0) GOTO 9999 IF (IDR1.NE.0) IDR1 = 100*IDR1 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN AMDIF1 = ABS(AMCH1-AMCH1N) AMDIF2 = ABS(AMCH2-AMCH2N) IF (AMDIF2.LT.AMDIF1) THEN CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, & AMCH2,AMCH2N,AMCH1,IREJ1) IF (IREJ1.GT.0) GOTO 9999 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) IF (IREJ1.NE.0) GOTO 9999 IF (IDR1.NE.0) IDR1 = 100*IDR1 ELSE CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, & AMCH1,AMCH1N,AMCH2,IREJ1) IF (IREJ1.GT.0) GOTO 9999 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 IF (IDR2.NE.0) IDR2 = 100*IDR2 ENDIF ENDIF ENDIF * store final configuration for energy-momentum cons. check IF (LEMCCK) THEN CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) IF (IREJ1.NE.0) GOTO 9999 ENDIF * put partons and chains into DTEVT1 DO 10 I=1,4 PCH1(I) = PP1(I)+PT1(I) PCH2(I) = PP2(I)+PT2(I) 10 CONTINUE CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), & PP1(3),PP1(4),0,0,0) CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), & PT1(3),PT1(4),0,0,0) KCH = 100+IDCH(MOP1)*10+1 CALL DT_EVTPUT(KCH,88888,-2,-1, & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), & PP2(3),PP2(4),0,0,0) CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), & PT2(3),PT2(4),0,0,0) KCH = KCH+1 CALL DT_EVTPUT(KCH,88888,-2,-1, & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) RETURN 9999 CONTINUE IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN * "cancel" sea-sea chains CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) IF (IREJ1.NE.0) GOTO 9998 **sr 16.5. flag for EVENTB IREJ = -1 RETURN ENDIF 9998 CONTINUE IREJ = 1 RETURN END * *===getemu=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,E12.3)') & 'DT_GETEMU: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 * *===getpje=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) LOGICAL LFLIP * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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=8000) 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=2000) 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/ DATA IESSS1,IESSS2,IESSS4,IESSS5,IESSS6,IESSS7,IESSS8,IESSS9 * /0,0,0,0,0,0,0,0/ 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 IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' STOP ' DT_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 (LPRI.GT.4 .AND. ILOOP.EQ.MAXLOP) & WRITE(LOUT,*) ' DT_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 (LPRI.GT.4 .AND. ILOOP.EQ.MAXLOP) & WRITE(LOUT,*) ' DT_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 C J.R.19.11.01 CALL DT_RANNOR(R1,R2) VHKK(KK,NHKK) = VHKK(KK,M2PTN1)+R1*0.8D-12 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 .AND. LPRI.GT.4) & WRITE(LOUT,*) ' DT_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 C J.R.19.11.01 CALL DT_RANNOR(R1,R2) VHKK(KK,NHKK) = VHKK(KK,M2PTN)+R1*0.8D-12 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 C J.R.19.11.01 CALL DT_RANNOR(R1,R2) VHKK(KK,NHKK) = VHKK(KK,M2PTN2)+R1*0.8D-12 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 C J.R.19.11.01 CALL DT_RANNOR(R1,R2) VHKK(KK,NHKK) = VHKK(KK,MO2)+R1*0.8D-12 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 1000 FORMAT(1X,'DT_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,'DT_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 IF (LPRI.GT.4) . 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 C9999 CONTINUE C IREJ = 1 C RETURN END * * *===getptn=============================================================* * CDECK ID>, DT_GETPTN SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) ************************************************************************ * This subroutine collects partons at chain ends from temporary * * commons and puts them into DTEVT1. * * This version dated 15.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) LOGICAL LCHK PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * auxiliary common for chain system storage (DTUNUC 1.x) COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF * x-values of partons (DTUNUC 1.x) COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), & XTVQ(MAXVQU),XTVD(MAXVQU), & XPSQ(MAXSQU),XPSAQ(MAXSQU), & XTSQ(MAXSQU),XTSAQ(MAXSQU) * flavors of partons (DTUNUC 1.x) COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), & IPSQ(MAXSQU),IPSQ2(MAXSQU), & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), & ITSQ(MAXSQU),ITSQ2(MAXSQU), & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), & KKPROJ(MAXVQU),KKTARG(MAXVQU) * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, & IXPV,IXPS,IXTV,IXTS, & INTVV1(MAXVQU),INTVV2(MAXVQU), & INTSV1(MAXVQU),INTSV2(MAXVQU), & INTVS1(MAXVQU),INTVS2(MAXVQU), & INTSS1(MAXSQU),INTSS2(MAXSQU), & INTDV1(MAXVQU),INTDV2(MAXVQU), & INTVD1(MAXVQU),INTVD2(MAXVQU), & INTDS1(MAXSQU),INTDS2(MAXSQU), & INTSD1(MAXSQU),INTSD2(MAXSQU) * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ IREJ = 0 NCSY = 0 NPOINT(2) = NHKK+1 * sea-sea chains DO 10 I=1,NSS IF (ISKPCH(1,I).EQ.99) GOTO 10 ICCHAI(1,1) = ICCHAI(1,1)+2 IDXP = INTSS1(I) IDXT = INTSS2(I) MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) MOT = JDAHKK(1,IPOST(IFROST(IDXT))) DO 11 K=1,4 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) 11 CONTINUE PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 ENDIF IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,1) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,1) CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,1) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,1) NCSY = NCSY+1 10 CONTINUE * disea-sea chains DO 20 I=1,NDS IF (ISKPCH(2,I).EQ.99) GOTO 20 ICCHAI(1,2) = ICCHAI(1,2)+2 IDXP = INTDS1(I) IDXT = INTDS2(I) MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) MOT = JDAHKK(1,IPOST(IFROST(IDXT))) DO 21 K=1,4 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) 21 CONTINUE PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) . WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 ENDIF IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,2) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,2) CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,2) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,2) NCSY = NCSY+1 20 CONTINUE * sea-disea chains DO 30 I=1,NSD IF (ISKPCH(3,I).EQ.99) GOTO 30 ICCHAI(1,3) = ICCHAI(1,3)+2 IDXP = INTSD1(I) IDXT = INTSD2(I) MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) MOT = JDAHKK(1,IPOST(IFROST(IDXT))) DO 31 K=1,4 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) 31 CONTINUE PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 ENDIF IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,3) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,3) CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,3) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,3) NCSY = NCSY+1 30 CONTINUE * disea-valence chains DO 50 I=1,NDV IF (ISKPCH(5,I).EQ.99) GOTO 50 ICCHAI(1,5) = ICCHAI(1,5)+2 IDXP = INTDV1(I) IDXT = INTDV2(I) MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) DO 51 K=1,4 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) PT2(K) = XTVD(IDXT) *PHKK(K,MOT) 51 CONTINUE PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 ENDIF IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,5) CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,5) CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,5) CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,5) NCSY = NCSY+1 50 CONTINUE * valence-sea chains DO 60 I=1,NVS IF (ISKPCH(6,I).EQ.99) GOTO 60 ICCHAI(1,6) = ICCHAI(1,6)+2 IDXP = INTVS1(I) IDXT = INTVS2(I) MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) MOT = JDAHKK(1,IPOST(IFROST(IDXT))) DO 61 K=1,4 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) PP2(K) = XPVD(IDXP) *PHKK(K,MOP) PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) 61 CONTINUE IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) CALL DT_CHKCSY(IFP1,IFT1,LCHK) IF (LCHK) THEN CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,6) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,6) CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,6) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,6) PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) ELSE CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,6) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,6) CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,6) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,6) PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 & +(PP1(3)+PT2(3))**2) ECH = PP1(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 & +(PP2(3)+PT1(3))**2) ECH = PP2(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) ENDIF IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 ENDIF NCSY = NCSY+1 60 CONTINUE * sea-valence chains DO 40 I=1,NSV IF (ISKPCH(4,I).EQ.99) GOTO 40 ICCHAI(1,4) = ICCHAI(1,4)+2 IDXP = INTSV1(I) IDXT = INTSV2(I) MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) DO 41 K=1,4 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) PT1(K) = XTVD(IDXT) *PHKK(K,MOT) PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) 41 CONTINUE PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 ENDIF IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,4) CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,4) CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,4) CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,4) NCSY = NCSY+1 40 CONTINUE * valence-disea chains DO 70 I=1,NVD IF (ISKPCH(7,I).EQ.99) GOTO 70 ICCHAI(1,7) = ICCHAI(1,7)+2 IDXP = INTVD1(I) IDXT = INTVD2(I) MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) MOT = JDAHKK(1,IPOST(IFROST(IDXT))) DO 71 K=1,4 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) PP2(K) = XPVD(IDXP) *PHKK(K,MOP) PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) 71 CONTINUE IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) CALL DT_CHKCSY(IFP1,IFT1,LCHK) IF (LCHK) THEN CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,7) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,7) CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,7) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,7) PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) ELSE CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), & 0,0,7) CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), & 0,0,7) CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), & 0,0,7) CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), & 0,0,7) PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 & +(PP1(3)+PT2(3))**2) ECH = PP1(4)+PT2(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 & +(PP2(3)+PT1(3))**2) ECH = PP2(4)+PT1(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) ENDIF IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 ENDIF NCSY = NCSY+1 70 CONTINUE * valence-valence chains DO 80 I=1,NVV IF (ISKPCH(8,I).EQ.99) GOTO 80 ICCHAI(1,8) = ICCHAI(1,8)+2 IDXP = INTVV1(I) IDXT = INTVV2(I) MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) DO 81 K=1,4 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) PP2(K) = XPVD(IDXP)*PHKK(K,MOP) PT1(K) = XTVD(IDXT)*PHKK(K,MOT) PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) 81 CONTINUE IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) * check for diffractive event IDIFF = 0 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. & (IP.EQ.1).AND.(NN.EQ.1)) THEN DO 800 K=1,4 PP(K) = PP1(K)+PP2(K) PT(K) = PT1(K)+PT2(K) 800 CONTINUE ISTCK = NHKK CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) C IF (IREJ1.NE.0) GOTO 9999 IF (IREJ1.NE.0) THEN IDIFF = 0 NHKK = ISTCK ENDIF ELSE IDIFF = 0 ENDIF IF (IDIFF.EQ.0) THEN * valence-valence chain system CALL DT_CHKCSY(IFP1,IFT1,LCHK) IF (LCHK) THEN * baryon-baryon CALL DT_EVTPUT(-21,IFP1,MOP,0, & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) CALL DT_EVTPUT(-22,IFT1,MOT,0, & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) CALL DT_EVTPUT(-21,IFP2,MOP,0, & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) CALL DT_EVTPUT(-22,IFT2,MOT,0, & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) ELSE * antibaryon-baryon CALL DT_EVTPUT(-21,IFP1,MOP,0, & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) CALL DT_EVTPUT(-22,IFT2,MOT,0, & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) CALL DT_EVTPUT(-21,IFP2,MOP,0, & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) CALL DT_EVTPUT(-22,IFT1,MOT,0, & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 & +(PP1(3)+PT2(3))**2) ECH = PP1(4)+PT2(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 & +(PP2(3)+PT1(3))**2) ECH = PP2(4)+PT1(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) ENDIF IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN AM1 = SQRT(AM1) AM2 = SQRT(AM2) IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 ENDIF NCSY = NCSY+1 ENDIF 80 CONTINUE IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 * energy-momentum & flavor conservation check IF (ABS(IDIFF).NE.1) THEN IF (IDIFF.NE.0) THEN IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, & 1,3,10,IREJ) ELSE IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, & 1,3,10,IREJ) ENDIF IF (IREJ.NE.0) THEN CALL DT_EVTOUT(4) STOP ENDIF ENDIF RETURN C9999 CONTINUE C IREJ = 1 C RETURN END * *===getspt=============================================================* * CDECK ID>, DT_GETSPT SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) ************************************************************************ * This version dated 12.12.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT * flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), & PT2(4),PT2I(4),P1(4),P2(4), & IFP1(2),IFP2(2),IFT1(2),IFT2(2), & PTOTI(4),PTOTF(4),DIFF(4) IC = 0 IREJ = 0 C B33P = 4.0D0 C B33T = 4.0D0 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 REDU = 1.0D0 C B33P = 3.5D0 C B33T = 3.5D0 B33P = 4.0D0 B33T = 4.0D0 IF (IDIFF.NE.0) THEN B33P = 16.0D0 B33T = 16.0D0 ENDIF DO 1 I=1,4 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) PP1(I) = PP1I(I) PP2(I) = PP2I(I) PT1(I) = PT1I(I) PT2(I) = PT2I(I) 1 CONTINUE * get initial chain masses PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1 = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2 = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN IF (IOULEV(1).GT.0 .AND. LPRI.GT.4) & WRITE(LOUT,'(1X,A,2G10.3)')'DT_GETSPT:too small chain masses 1', & AM1,AM2 GOTO 9999 ENDIF AM1 = SQRT(AM1) AM2 = SQRT(AM2) AM1N = ZERO AM2N = ZERO MODE = 0 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN C MODE = 0 C ELSE C MODE = 1 C IF (AM1.LT.0.6) THEN C B33P = 10.0D0 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN C ENDIF C IF (AM2.LT.0.6) THEN C B33T = 10.0D0 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN C ENDIF C ENDIF * check chain masses for very low mass chains C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, C & AM1,DUM,-IDCH1,IREJ1) C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, C & AM2,DUM,-IDCH2,IREJ2) C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN C B33P = 20.0D0 C B33T = 20.0D0 C ENDIF JMSHL = IMSHL 2 CONTINUE IC = IC+1 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T IF (MOD(IC,18).EQ.0) REDU = 0.0D0 C IF (MOD(IC,19).EQ.0) JMSHL = 0 IF (MOD(IC,20).EQ.0) GOTO 7 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' C RETURN C GOTO 9999 C ENDIF * get transverse momentum IF (LINTPT) THEN ES = -2.0D0/(B33P**2) & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) HPSP = HPSP*REDU ES = -2.0D0/(B33T**2) & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) HPST = HPST*REDU ELSE HPSP = ZERO HPST = ZERO ENDIF CALL DT_DSFECF(SFE1,CFE1) CALL DT_DSFECF(SFE2,CFE2) IF (MODE.EQ.0) THEN PP1(1) = PP1I(1)+HPSP*CFE1 PP1(2) = PP1I(2)+HPSP*SFE1 PP2(1) = PP2I(1)-HPSP*CFE1 PP2(2) = PP2I(2)-HPSP*SFE1 PT1(1) = PT1I(1)+HPST*CFE2 PT1(2) = PT1I(2)+HPST*SFE2 PT2(1) = PT2I(1)-HPST*CFE2 PT2(2) = PT2I(2)-HPST*SFE2 ELSE PP1(1) = PP1I(1)+HPSP*CFE1 PP1(2) = PP1I(2)+HPSP*SFE1 PT1(1) = PT1I(1)-HPSP*CFE1 PT1(2) = PT1I(2)-HPSP*SFE1 PP2(1) = PP2I(1)+HPST*CFE2 PP2(2) = PP2I(2)+HPST*SFE2 PT2(1) = PT2I(1)-HPST*CFE2 PT2(2) = PT2I(2)-HPST*SFE2 ENDIF * put partons on mass shell XMP1 = 0.0D0 XMT1 = 0.0D0 IF (JMSHL.EQ.1) THEN XMP1 = PYMASS(IFPR1) XMT1 = PYMASS(IFTA1) ENDIF CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 2 DO 3 I=1,4 PTOTF(I) = P1(I)+P2(I) PP1(I) = P1(I) PT1(I) = P2(I) 3 CONTINUE XMP2 = 0.0D0 XMT2 = 0.0D0 IF (JMSHL.EQ.1) THEN XMP2 = PYMASS(IFPR2) XMT2 = PYMASS(IFTA2) ENDIF CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 2 DO 4 I=1,4 PTOTF(I) = PTOTF(I)+P1(I)+P2(I) PP2(I) = P1(I) PT2(I) = P2(I) 4 CONTINUE * check consistency DO 5 I=1,4 DIFF(I) = PTOTI(I)-PTOTF(I) 5 CONTINUE IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,4G10.3)') 'DT_GETSPT: inconsistencies ',DIFF GOTO 9999 ENDIF PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) & THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,2(4G10.3,/))') & 'DT_GETSPT: inconsistent masses', & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 * sr 22.11.00: commented. It should only have inconsistent masses for * ultrahigh energies due to rounding problems C GOTO 9999 ENDIF * get chain masses PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 & +(PP1(3)+PT1(3))**2) ECH = PP1(4)+PT1(4) AM1N = (ECH+PTOCH)*(ECH-PTOCH) PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 & +(PP2(3)+PT2(3))**2) ECH = PP2(4)+PT2(4) AM2N = (ECH+PTOCH)*(ECH-PTOCH) IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN IF (IOULEV(1).GT.0 .AND. LPRI.GT.4) & WRITE(LOUT,'(1X,A,2G10.3)')'DT_GETSPT:too small chain masses 2', & AM1N,AM2N GOTO 2 ENDIF AM1N = SQRT(AM1N) AM2N = SQRT(AM2N) * check chain masses for very low mass chains CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, & AM1N,DUM,-IDCH1,IREJ1) IF (IREJ1.NE.0) GOTO 2 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, & AM2N,DUM,-IDCH2,IREJ2) IF (IREJ2.NE.0) GOTO 2 7 CONTINUE IF (AM1N.GT.ZERO) THEN AM1 = AM1N AM2 = AM2N ENDIF DO 6 I=1,4 PP1I(I) = PP1(I) PP2I(I) = PP2(I) PT1I(I) = PT1(I) PT2I(I) = PT2(I) 6 CONTINUE RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===glaube=============================================================* * CDECK ID>, DT_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)* * This is an update of the original routine SHMAKO by J.Ranft/HJM * * This version dated 22.03.96 is revised by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * Glauber formalism: parameters COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), & BMAX(NCOMPX),BSTEP(NCOMPX), & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), & NSITEB,NSTATB * Glauber formalism: cross sections COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), & BSLOPE,NEBINI,NQBINI * Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ * properties of photon/lepton projectiles COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * Glauber formalism: flags and parameters for statistics LOGICAL LPROD CHARACTER*8 CGLB COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD DIMENSION JS(MAXNCL),JT(MAXNCL) NTARG = ABS(NIDX) * get actual energy from /DTLTRA/ ECMNOW = UMO Q2 = VIRT cdh if (LPRI.GT.4) write(LOUT,*)'DT_GLAUBE:IOGLB=',IOGLB,' NIDX=',NIDX cdh * new patch for pre-initialized variable projectile/target/energy runs IF (IOGLB.EQ.100) THEN if (NIDX.eq.-2) then c write(0,*) ' -- dt_glaube -- skip call into dt_glbset()' else CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) endif * * 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 * *===glbini=============================================================* * CDECK ID>, DT_GLBINI SUBROUTINE DT_GLBINI(WHAT) ************************************************************************ * Pre-initialization of profile function * * This version dated 28.11.00 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 cdh datadir for path to the data sets to be read in by dpmjet/phojet COMMON /DATADIR/ DATADIR CHARACTER*132 DATADIR * 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) 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 c DATA ECMXPI / 100000.0D0 / * *-------------------------------------------------------------------------- * general initializations * LPRI = 20 LOUT = 6 * 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. * * open Glauber-data output file IDX = INDEX(CGLB,' ') K = 8 IF (IDX.GT.1) K = IDX-1 cdh OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') c modification for use with corsika using path to data file in DATADIR OPEN(LDAT,STATUS='UNKNOWN', & FILE=DATADIR(1:INDEX(DATADIR,' ')-1)//CGLB(1:K)//'.glb') * *-------------------------------------------------------------------------- * 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 ' DT_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 ' DT_GLBINI: NASAV > MAXMSS ! ' IASAV(NASAV) = IP ELSE DO 11 IPROJ=1,NPROJ KPROJ = JPEACH+IPROJ*JPSTEP NASAV = NASAV+1 IF (NASAV.GT.MAXMSS) STOP ' DT_GLBINI: NASAV > MAXMSS ! ' IASAV(NASAV) = KPROJ 11 CONTINUE IF (KPROJ.LT.IP) THEN NASAV = NASAV+1 IF (NASAV.GT.MAXMSS) STOP ' DT_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 ' DT_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 ** newer PHOJET versions initialize new proj/targ combinations dynamically ** no need to call the initialization again CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) C 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 * *===glbset=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 cdh datadir for path to the data sets to be read in by dpmjet/phojet COMMON /DATADIR/ DATADIR CHARACTER*132 DATADIR * 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) 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 = 8 IF (IDX.GT.1) K = IDX-1 cdh OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') c modification for use with corsika using path to data file in DATADIR IF (LPRI.GT.4) & WRITE(LOUT,*)'DT_GLBSET:read glauber parameter from file ', & DATADIR(1:INDEX(DATADIR,' ')-1)//CGLB(1:K),'.glb',' K=',K OPEN(LDAT,STATUS='UNKNOWN', & FILE=DATADIR(1:INDEX(DATADIR,' ')-1)//CGLB(1:K)//'.glb') IF (LPRI.GT.4) & WRITE(LOUT,1003) CGLB(1:K) 1003 FORMAT(/,' DT_GLBSET: glauger parameter data set opend for', & ' file ',A,'.glb') * * 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' IF (LCMS) THEN IF (LPRI.GT.4) & WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN ELSE IF (LPRI.GT.4) & WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN ENDIF 1001 FORMAT(2X,A5,' E_lo = ',1P,E10.3,' E_hi = ',1P,E10.3,4X, & 'No. of bins:',I5,/) ELO = LOG10(ABS(ELO)) EHI = LOG10(ABS(EHI)) DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) * now the projectile mass bins IF (LPRI.GT.4) & WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) IF (NABIN.LT.18) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) ELSE IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) ENDIF IF (NABIN.GT.MAXBIN) STOP ' DT_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) IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) ENDIF ENDIF * now the target mass bins IF (LPRI.GT.4) & WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) IF (NBBIN.LT.18) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) ELSE IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) ENDIF IF (NBBIN.GT.MAXBIN) STOP ' DT_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) IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & 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 * MAXOFF = 2 is for pion and Kaon 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 ' DT_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 ' DT_GLBSET: NSET.NE.NSET0 !' IF (LPRI.GT.4) & WRITE(LOUT,'(/,1X,A)') & ' projectiles other than protons and nuclei: (particle index)' IF (NAIDX.GT.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) ELSE IF (LPRI.GT.4) & WRITE(LOUT,'(6X,A)') 'none' ENDIF * CLOSE(LDAT) IF (LPRI.GT.4) & 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 WRITE(*,*) 'DT_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 ' DT_GLBSET: IDPROJ > 25 !' IF (IOFFST(IDPROJ).EQ.-1) THEN STOP ' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*)' DT_GLBSET: Too low energy! (E_lo,E)',ELO,E LFRST1 = .FALSE. ENDIF E = ELO ENDIF IF (E.GT.EHI) THEN IF (LFRST2) THEN IF (LPRI.GT.4) & WRITE(LOUT,*)' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_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 ' DT_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 IF (LPRI.GT.4) & WRITE(LOUT,*)' DT_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 * *===hadcol=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) LOGICAL LSTART * event history PARAMETER (NMXHKK=250000) 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_HADCOL: Scattering handled by HADRIN') IF (LPRI.GT.4) & WRITE(LOUT,1001) TAUFOR 1001 FORMAT(/,1X,'DT_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 * * *===hadprp=============================================================* * CDECK ID>, DT_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 / *----------------------------------- quark content of hadrons: * 1, 2, 3, 4 - u, d, s, c * -1,-2,-3,-4 - au,ad,as,ac 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 * *===hadrin=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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, & IFUSION,IFLOW * 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) .AND. LPRI.GT.4) & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') 'DT_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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_HADRIN' GOTO 9999 ENDIF IF (IRH.EQ.1) GOTO 9998 ELSE *af: 1 line, make the compiler happy INTHAD = 0 IF (LPRI.GT.4) & WRITE(LOUT,1001) MODE,INTHAD 1001 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 1002 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), & PFSP(5,NFSP) 1003 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') 'DT_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 * *===himult=============================================================* * CDECK ID>, DT_HIMULT SUBROUTINE DT_HIMULT(MODE) ************************************************************************ * Tables of average energies/multiplicities. * * This version dated 30.08.2000 is written by S. Roesler * * Last change 5.5.2012 by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_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.207) 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 IF (LPRI.GT.4) &WRITE(LOUT,3000) 3000 FORMAT(/,1X,'DT_HIMULT:',21X,'particle - statistics',/, & 29X,'---------------------',/) IF (MULDEF.EQ.1) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' ELSE BETGRE = 0.7D0 BETBLC = 0.23D0 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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.LT.207) THEN IF (LPRI.GT.4) & 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) ELSE IF (LPRI.GT.4) & WRITE(LOUT,3004) ANAMEH(I-206),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 * *===histat=============================================================* * CDECK ID>, DT_HISTAT SUBROUTINE DT_HISTAT(IDX,MODE) ************************************************************************ * This version dated 26.02.96 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) PARAMETER (NDIM=199) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL * event history PARAMETER (NMXHKK=250000) 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) * 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 * 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 PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 SAVE / PAREVT / PARAMETER ( MXFFBK = 6 ) PARAMETER ( MXZFBK = 10 ) PARAMETER ( MXNFBK = 12 ) PARAMETER ( MXAFBK = 16 ) PARAMETER ( MXASST = 25 ) PARAMETER ( NXAFBK = MXAFBK + 1 ) PARAMETER ( NXZFBK = INT(MXZFBK + MXFFBK / 3 & + MXASST - NXAFBK) ) PARAMETER ( NXNFBK = INT(MXNFBK + MXFFBK / 3 & + MXASST - NXAFBK) ) PARAMETER ( MXPSST = 700 ) PARAMETER ( MXPPFB = 42500 ) PARAMETER ( MXPSFB = 43000 ) PARAMETER ( IBFRBK = 73 ) 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), IFBKLV (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, & IFBPSI, IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, & LFRMBK, LNCMSS SAVE / FRBKCM / 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, LPEXLV, 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, LPEXLV, LEEXLV, & LGEXLV SAVE / EVAFLG / * 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.207) THEN NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 ELSEIF (IDBJT.EQ.208) THEN NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 ELSEIF (IDBJT.EQ.209) THEN NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 ELSEIF (IDBJT.EQ.210) 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 IF (LPRI.GT.4) & WRITE(LOUT,3000) 3000 FORMAT(/,1X,'DT_HISTAT:',14X,'statistics - target emulsion',/, & 22X,'----------------------------',/,/,19X, & 'mass charge fraction',/,39X, & 'input treated',/) DO 30 I=1,NCOMPO IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC 3001 FORMAT(/,' DT_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) IF (LPRI.GT.4) &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,/) IF (LPRI.GT.4) &WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, & IREXCI(1)+IREXCI(2)+IREXCI(3) 3003 FORMAT(/,1X,'DT_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,/) IF (LPRI.GT.4) &WRITE(LOUT,3004) 3004 FORMAT(/,22X,'1) before evaporation-step:',/) ICEV = MAX(NRESEV(2),1) IF (LPRI.GT.4) &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.GE.1)CMSG(1) = 'requested ' IF (LFRMBK) CMSG(2) = 'requested ' IF (LDEEXG) CMSG(3) = 'requested ' IF (LPRI.GT.4) & 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.GE.1) THEN IF (LPRI.GT.4) . 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.(IFISS.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 IF (LPRI.GT.4) & 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 * *===histog=============================================================* * CDECK ID>, DT_HISTOG SUBROUTINE DT_HISTOG(MODE) ************************************************************************ * This version dated 25.03.96 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LFSP,LRNL * event history PARAMETER (NMXHKK=250000) 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 * *===indexd=============================================================* * CDECK ID>, DT_INDEXD SUBROUTINE DT_INDEXD(KA,KB,IND) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===ininuc=============================================================* * CDECK ID>, DT_ININUC SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) ************************************************************************ * Samples initial configuration of nucleons in nucleus with mass NMASS * * including Fermi-momenta (if reqested). * * ID BAMJET-code for hadrons (instead of nuclei) * * NMASS mass number of nucleus (number of nucleons) * * NCH charge of nucleus * * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * * IMODE = 1 projectile nucleus * * = 2 target nucleus * * = 3 target nucleus (E_lab, DT_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. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 SAVE / PAREVT / 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, LPEXLV, 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, LPEXLV, LEEXLV, & LGEXLV SAVE / EVAFLG / PARAMETER ( MXFFBK = 6 ) PARAMETER ( MXZFBK = 10 ) PARAMETER ( MXNFBK = 12 ) PARAMETER ( MXAFBK = 16 ) PARAMETER ( MXASST = 25 ) PARAMETER ( NXAFBK = MXAFBK + 1 ) PARAMETER ( NXZFBK = INT(MXZFBK + MXFFBK / 3 + & MXASST - NXAFBK ) ) PARAMETER ( NXNFBK = INT(MXNFBK + MXFFBK / 3 + & MXASST - NXAFBK ) ) PARAMETER ( MXPSST = 700 ) PARAMETER ( MXPPFB = 42500 ) PARAMETER ( MXPSFB = 43000 ) PARAMETER ( IBFRBK = 73 ) 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), IFBKLV (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, & IFBPSI, IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, & LFRMBK, LNCMSS SAVE / FRBKCM / * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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, & IFUSION,IFLOW * 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 INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYDAT3/ * 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=64) 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 ','FUSION ','FLOW ', & 'COLLSCA ','CHTWOMES ',' ',' ' / 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 c IF (ITRSPT.NE.1) THEN c CALL FLRNOC (ISRND1,ISRND2,ISEED1,ISEED2) c ISRND1 =-1 c INSEED =1 c CALL RNINIT (INSEED,ISRND1,ISEED1,ISEED2) c END IF IF (ITRSPT.NE.1) THEN CALL DT_RNDMST(22,54,76,92) CALL DT_RNDMTE(1) 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 C**af IF (NCASES.EQ.-1) THEN C IP = NPMASS C IPZ = NPCHAR C PPN = EPNSAV C EPN = ZERO C CMENER = ZERO C LEINP = .TRUE. C MKCRON = 0 C WHAT(1) = 1 C WHAT(2) = 0 C CODEWD = 'START ' C GOTO 900 C ENDIF IF (NCASES.EQ.-1) THEN IP = NPMASS IPZ = NPCHAR IT = NTMASS ITZ = NTCHAR PPN = EPNSAV VARELO = 10.D0 VAREHI = EPN*1.1D0 EPN = ZERO CMENER = ZERO LEINP = .TRUE. MKCRON = 0 WHAT(1) = 1 WHAT(2) = 0 CODEWD = 'START ' LEVPRT = .TRUE. GOTO 900 ENDIF * read control card from input-unit LINP READ(LINP,'(A78)',END=9999) CLINE IF (CLINE(1:1).EQ.'*') THEN * comment-line IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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 , * FUSION , FLOW ,COLLSCA , CHTWOMES , ) & 650 , 660 , 670 , 680 , 690,690 ) , 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 * * * ********************************************************************* * * * control card: codewd = EVAP * * * * evaporation module * * * * Obsoleted by A.Ferrari, it can no longer work since FLUKA2005.6 * * * ********************************************************************* 220 CONTINUE 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 IREJ1= LPRI CALL PHO_INIT(LINP,LOUT,IREJ1) IF (IREJ1.NE.0) THEN IF (LPRI.GT.4) & 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) C IP = IPLOW+(NCIP-1)*IDIP 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 IF (LPRI.GT.4) & WRITE(LOUT,1380) 1380 FORMAT(1X,'DT_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 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 IF (LPRI.GT.4) & WRITE(LOUT,1003) 1003 FORMAT(1X,'DT_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. *(ICENTR.EQ.-100).OR. (XSFRAC.LT.0.5D0)) THEN IF (LEVPRT) THEN IF (LPRI.GT.4) & WRITE(LOUT,1004) 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', & ' central collisions forced.') ENDIF ENDIF * initialization of evaporation-module * initialize evaporation if the code is not used as Fluka event generator IF (ITRSPT.NE.1) THEN ENDIF * save the default JETSET-parameter CALL DT_JSPARA(0) * force use of phojet for g-A IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 * initialization of nucleon-nucleon event generator IF (MCGENE.EQ.2) CALL DT_PHOINI * initialization of LEPTO event generator IF (MCGENE.EQ.3) THEN STOP ' This version does not contain LEPTO !' ENDIF * initialization of quasi-elastic neutrino scattering IF (MCGENE.EQ.4) THEN IF (IJPROJ.EQ.5) THEN NEUTYP = 1 ELSEIF (IJPROJ.EQ.6) THEN NEUTYP = 2 ELSEIF (IJPROJ.EQ.135) THEN NEUTYP = 3 ELSEIF (IJPROJ.EQ.136) THEN NEUTYP = 4 ELSEIF (IJPROJ.EQ.133) THEN NEUTYP = 5 ELSEIF (IJPROJ.EQ.134) THEN NEUTYP = 6 ENDIF ENDIF * normalize fractions of emulsion components IF (NCOMPO.GT.0) THEN SUMFRA = ZERO DO 491 I=1,NCOMPO SUMFRA = SUMFRA+EMUFRA(I) 491 CONTINUE IF (SUMFRA.GT.ZERO) THEN DO 492 I=1,NCOMPO EMUFRA(I) = EMUFRA(I)/SUMFRA 492 CONTINUE ENDIF ENDIF * disallow Cronin's multiple scattering for nucleus-nucleus interactions IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1005) 1005 FORMAT(/,1X,'DT_INIT: multiple scattering disallowed',/) MKCRON = 0 ENDIF * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) IF (NCOMPO.LE.0) THEN CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) ELSE DO 493 I=1,NCOMPO CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) 493 CONTINUE 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 IF (LPRI.GT.4) &WRITE(LOUT,9000) 9000 FORMAT(1X,'---> unexpected end of input !') 640 CONTINUE STOP ********************************************************************* * * * control card: codewd = FUSION * * * * WHAT(1)=1 FUSION default: no FUSION * * * * what (2..6) no meaning * * * ********************************************************************* 650 CONTINUE IFUSION=0 IFUSION=ABS(WHAT(1)) IF (LPRI.GT.4) &WRITE(LOUT,*)' DT_INIT : IFUSION = ',IFUSION GOTO 10 ********************************************************************* * * * control card: codewd = FLOW * * * * * * * * what (1..6) no meaning * * * ********************************************************************* 660 CONTINUE GOTO 10 ********************************************************************* * * * control card: codewd = COLLSCA * * * * * * * * what (1..6) no meaning * * * ********************************************************************* 670 CONTINUE GOTO 10 ********************************************************************* * * * control card: codewd = CHTWOMES * * * * * * * * what (1..6) no meaning * * * ********************************************************************* 680 CONTINUE GOTO 10 ********************************************************************* * * * control card: codewd = * * * * * * * * what (1..6) no meaning * * * ********************************************************************* 690 CONTINUE STOP END * *===initjs=============================================================* * CDECK ID>, DT_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 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) LOGICAL LFIRST,LFIRDT,LFIRPH PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 = 208 ) PARAMETER ( KPN140 = 209 ) PARAMETER ( KPK89P = 36 ) PARAMETER ( KPK890 = 37 ) PARAMETER ( KPK89M = 38 ) PARAMETER ( KPAK89 = 39 ) PARAMETER ( KPS13P = 104 ) PARAMETER ( KPS130 = 105 ) PARAMETER ( KPS13M = 106 ) PARAMETER ( KPXSI0 = 97 ) PARAMETER ( KPXSIM = 98 ) 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 / CHPART / ANAME (-6:IDMAXP) SAVE / PART / SAVE / CHPART / INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT2/ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYDAT3/ * 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, & IFUSION,IFLOW 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/ EXTERNAL MCIHAD,MPDGHA PARAMETER (NUNSTAB = 11) DIMENSION IUNSTAB(NUNSTAB) * XI_C(0), XI_C(+), OMEGA_C(0), XI_C'(0), XI_C'(+), * XI_C*(+)), SIGMA_C*(+), SIGMA_C*(++), XI_C*(0), * SIGMA_C*(0), D*0(2400)0 DATA IUNSTAB $ / 4132,4232,4332,4312,4322, $ 4324,4214,4224,4314, $ 4114,10421/ DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ IF (LFIRST) THEN * save default settings PDEF1 = PARJ(1) PDEF2 = PARJ(2) PDEF3 = PARJ(3) PDEF4 = PARJ(4) 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 ! do not enlarge MSTU(4) > 4000 because of cdh ! problems in endles looping with NHKK > NMXHKK cdh MSTU(4) = 20000 cdh MSTU(5) = 20000 * increase maximum number of pythia-error prints MSTU(22) = 50000 cdh MSTU(22) = 10 ! (default value) * prevent particles decaying DO 1 I=1,35 IF (I.LT.34) THEN KC = PYCOMP(IDXSTA(I)) 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 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ENDIF 1 CONTINUE * prevent some charmed baryons which don't have a BAMJET code to be * set as stable DO I=1,NUNSTAB KC = PYCOMP(IUNSTAB(I)) MDCY(KC,1) = 1 KC = PYCOMP(-IUNSTAB(I)) !anti-particle MDCY(KC,1) = 1 END DO * * 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) DO J=1,NUNSTAB IF (ABS(IDPDG).EQ.IUNSTAB(J)) GOTO 5 END DO KC = PYCOMP(IDPDG) IF (KC .GT. 0) THEN IF (MDCY(KC,1).EQ.1) THEN IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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) * cdh 23.1.2017 **anfe Reset all parameters before changing anything. PARJ(1) = PDEF1 PARJ(2) = PDEF2 PARJ(3) = PDEF3 PARJ(4) = PDEF4 PARJ(5) = PDEF5 PARJ(6) = PDEF6 PARJ(7) = PDEF7 PARJ(18) = PDEF18 PARJ(19) = PDEF19 PARJ(21) = PDEF21 PARJ(41) = PDEF41 PARJ(42) = PDEF42 MSTJ(12) = MDEF12 cdh * PHOJET settings **anfe try PYTHIA default IF (MODE.EQ.1.OR.MODE.EQ.2) 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) c PARJ(1) = 0.085D0 c PARJ(2) = 0.26D0 c PARJ(3) = 0.8D0 c PARJ(11) = 0.38D0 c PARJ(18) = 0.3D0 c PARJ(19) = 0.4D0 c PARJ(41) = 0.3D0 c PARJ(42) = 0.86D0 **anfe 26.08.15 c PARJ(21) = 0.36D0 ! PARJ(1) = 0.09 ! PARJ(2) = 0.22 **anfe MSTJ(12) = 3 PARJ(1) = 0.08D0 PARJ(2) = 0.16D0 PARJ(3) = 0.9D0 PARJ(5) = 0.2D0 PARJ(7) = 0.85D0 PARJ(21) = 0.42D0 cdh 31.1.2017 PARJ(41) = 0.3D0 PARJ(42) = 0.85D0 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 C PARJ(18)=1.D0 C WRITE(6,*)' INITJS:',' MODE = ',MODE C DO 2222 I=1,50 C WRITE(6,*)' PARJ(',I,') = ',PARJ(I) C2222 CONTINUE C WRITE(6,*)' MSTJ(12) = ',MSTJ(12) RETURN END * *===inucas=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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, & IFUSION,IFLOW * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * nuclear potential LOGICAL LFERMI COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, & EBINDP(2),EBINDN(2),EPOT(2,210), & ETACOU(2),ICOUL,LFERMI * parameter for intranuclear cascade LOGICAL LPAULI COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI * final state after intranuclear cascade step COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC * nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN * statistics: residual nuclei COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), & NINCST(2,4),NINCEV(2), & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), & NRESPB(2),NRESCH(2),NRESEV(4), & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), & NEVAFI(2,2) DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), & PCAS1(5),PNUC(5),BGTA(4), & BGCAS(2),GACAS(2),BECAS(2), & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) DATA PDIF /0.545D0/ IREJ = 0 * update counter IF (NINCEV(1).NE.NEVHKK) THEN NINCEV(1) = NEVHKK NINCEV(2) = NINCEV(2)+1 ENDIF * "BAMJET-index" of this hadron IDCAS = IDBAM(IDXCAS) * skip gammas, electrons, etc.. IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN * Lorentz-trsf. into projectile rest system IF (AAM(IDCAS).LT.TINY2) RETURN 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) PTOCAS 1000 FORMAT(1X,'DT_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,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 1001 FORMAT(1X,'DT_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 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 * *===joihis=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=10, 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) IH1,IH2,IHISL 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) 1001 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) 1002 FORMAT(1X,'DT_JOIHIS: warning! joining histograms ',I3, & ' and ',I3,' failed at bin edge ',I3,/,21X, & 'X1,X2 = ',2E11.4) GOTO 9999 ENDIF 1 CONTINUE IF (LPRI.GT.4) &WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 1003 FORMAT(1X,'DT_JOIHIS: joining histograms ',I3,',',I3,' with ', & 'operation ',A,/,11X,'and factors ',2E11.4) IF (LPRI.GT.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 IF (LPRI.GT.4) & WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') & 'DT_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 IF (LPRI.GT.4) &WRITE(LOUT,1005) COPER 1005 FORMAT(1X,'DT_JOIHIS: unknown operation ',A) 9999 CONTINUE RETURN END * *===join===============================================================* * CDECK ID>, DT_JOIN SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) ************************************************************************ * This subroutine joins two q-aq chains to one qq-aqaq chain. * * IDX1, IDX2 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,2 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) 2 CONTINUE 1 CONTINUE * check consistency IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. & ((ID(1,1)*ID(2,1)).LT.0).OR. & ((ID(1,2)*ID(2,2)).LT.0)) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), & MO(2,2) 1000 FORMAT(1X,'DT_JOIN: incons. chain system! chain ',I4,':', & 2I5,' chain ',I4,':',2I5) ENDIF * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) 3 CONTINUE IF(ID(1,1).EQ.4)ID(1,1)=3 IF(ID(1,2).EQ.4)ID(1,2)=3 IF(ID(2,1).EQ.4)ID(2,1)=3 IF(ID(2,2).EQ.4)ID(2,2)=3 IF(ID(1,1).EQ.-4)ID(1,1)=-3 IF(ID(1,2).EQ.-4)ID(1,2)=-3 IF(ID(2,1).EQ.-4)ID(2,1)=-3 IF(ID(2,2).EQ.-4)ID(2,2)=-3 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) IST1 = ISTHKK(MO(1,1)) IST2 = ISTHKK(MO(1,2)) * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE * check new chain for lower mass limit IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, & AMCH,AMCHN,3,IREJ1) IF (IREJ1.NE.0) THEN NHKK = NHKK-2 GOTO 9999 ENDIF ENDIF ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 6 CONTINUE c WRITE(6,*)'Join chains IDX1,IDX2 ',IDX1,IDX2 RETURN 9999 CONTINUE IREJ = 1 RETURN END C * *===join2==============================================================* * CDECK ID>, DT_JOIN2 SUBROUTINE DT_JOIN2(IDX1,IDX2,IREJ) ************************************************************************ * This subroutine joins a q-aq and a q-qq chain to one qq-q chain. * * IDX1, IDX2 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(2,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,2 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join2 ',IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2) * check consistency IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. & ((ID(1,1)*ID(2,1)).LT.0).OR. & ((ID(1,2)*ID(2,2)).LT.0)) THEN C WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), C & MO(2,2) C1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', C & 2I5,' chain ',I4,':',2I5) ENDIF * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) 3 CONTINUE C IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) C IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) IST1 = ISTHKK(MO(1,1)) IST2 = ISTHKK(MO(1,2)) IF(IDD(1,1).GE.IDD(2,1))THEN IF1=1000*IDD(1,1)+100*IDD(2,1)+3 ELSE IF1=1000*IDD(2,1)+100*IDD(1,1)+3 ENDIF IDDD1=IDD(1,2)/1000 IDDD2=(IDD(1,2)-IDDD1*1000)/100 IF(IDDD1.EQ.-IDD(2,2))IF2=IDDD2 IF(IDDD2.EQ.-IDD(2,2))IF2=IDDD1 C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE * check new chain for lower mass limit C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN C AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) C CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, C & AMCH,AMCHN,3,IREJ1) C IF (IREJ1.NE.0) THEN C NHKK = NHKK-2 C GOTO 9999 C ENDIF C ENDIF ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 6 CONTINUE C WRITE(6,*)'Join chains IDX1,IDX2 ',IDX1,IDX2 RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===join3==============================================================* * CDECK ID>, DT_JOIN3 SUBROUTINE DT_JOIN3(IDX1,IDX2,IDX3,IREJ) ************************************************************************ * This subroutine joins a q-aq and a aq-q chain to a third chain. * * IDX1, IDX2 ,IDX3 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(3,2),ID(3,2),IDX(3),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(3,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IDX(3) = IDX3 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX3).NE.IDX3-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX3).NE.IDX3-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTT5=PHKK(1,IDX3-2)**2+PHKK(2,IDX3-2)**2 PPTT6=PHKK(1,IDX3-1)**2+PHKK(2,IDX3-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4,PPTT5,PPTT6) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,3 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join3 ' C * ,IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2),IDD(3,1),IDD(3,2),'NN', C *IDX1,MO(1,1),MO(1,2),IDX2,MO(2,1),MO(2,2),IDX3,MO(3,1),MO(3,2) * check consistency C IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. C & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. C & ((ID(1,1)*ID(2,1)).LT.0).OR. C & ((ID(1,2)*ID(2,2)).LT.0)) THEN C WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), C & MO(2,2) C1000 FORMAT(1X,'DT_JOIN3: incons. chain system! chain ',I4,':', C & 2I5,' chain ',I4,':',2I5) C ENDIF * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))+PHKK(K,MO(3,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))+PHKK(K,MO(3,2)) 3 CONTINUE C IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) C IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) IST1 = ISTHKK(MO(3,1)) IST2 = ISTHKK(MO(3,2)) IF(IDD(1,1).GE.IDD(2,1))THEN IF1=1000*IDD(1,1)+100*IDD(2,1)+3 ELSE IF1=1000*IDD(2,1)+100*IDD(1,1)+3 ENDIF IDDD1=IDD(1,2)/1000 IDDD2=(IDD(1,2)-IDDD1*1000)/100 IF(IDDD1.EQ.-IDD(2,2))IF2=IDDD2 IF(IDDD2.EQ.-IDD(2,2))IF2=IDDD1 IF1=IDD(3,1) IF2=IDD(3,2) C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE * check new chain for lower mass limit C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN C AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) C CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, C & AMCH,AMCHN,3,IREJ1) C IF (IREJ1.NE.0) THEN C NHKK = NHKK-2 C GOTO 9999 C ENDIF C ENDIF ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 IDHKK(IDX(3)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2))+ * VHKK(K,IDX(3)))/3.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2))+ * WHKK(K,IDX(3)))/3.0D0 6 CONTINUE C WRITE(6,*)'Join3 chains IDX1,IDX2,IDX3,NHKK ',IDX1,IDX2,IDX3,NHKK RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===join33=============================================================* * CDECK ID>, DT_JOIN33 SUBROUTINE DT_JOIN33(IDX1,IDX2,IDX3,IREJ) ************************************************************************ * This subroutine joins a q-aq and a aq-q chain to a third q-qq chain. * * IDX1, IDX2 ,IDX3 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(3,2),IDX(3),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(3,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IDX(3) = IDX3 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX3).NE.IDX3-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX3).NE.IDX3-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTT5=PHKK(1,IDX3-2)**2+PHKK(2,IDX3-2)**2 PPTT6=PHKK(1,IDX3-1)**2+PHKK(2,IDX3-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4,PPTT5,PPTT6) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,3 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join33' C * ,IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2),IDD(3,1),IDD(3,2),'NN', C *IDX1,MO(1,1),MO(1,2),IDX2,MO(2,1),MO(2,2),IDX3,MO(3,1),MO(3,2) * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))+PHKK(K,MO(3,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))+PHKK(K,MO(3,2)) 3 CONTINUE IST1 = ISTHKK(MO(3,1)) IST2 = ISTHKK(MO(3,2)) IF1=IDD(1,1) IDMM1=IDD(3,2)/1000 IDMM2=(IDD(3,2)-IDMM1*1000)/100 IF(IDD(1,2).EQ.-IDMM1)THEN IF(IDD(2,2).GE.IDMM2)IF2=1000*IDD(2,2)+100*IDMM2+3 IF(IDMM2.GT.IDD(2,2))IF2=1000*IDMM2+100*IDD(2,2)+3 ELSEIF(IDD(1,2).EQ.-IDMM2)THEN IF(IDD(2,2).GE.IDMM1)IF2=1000*IDD(2,2)+100*IDMM1+3 IF(IDMM1.GT.IDD(2,2))IF2=1000*IDMM1+100*IDD(2,2)+3 ENDIF C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 IDHKK(IDX(3)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2))+ * VHKK(K,IDX(3)))/3.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2))+ * WHKK(K,IDX(3)))/3.0D0 6 CONTINUE C WRITE(6,*)'Join3 chains IDX1,IDX2,IDX3,NHKK ',IDX1,IDX2,IDX3,NHKK RETURN 9999 CONTINUE IREJ = 1 RETURN END * * *===join333============================================================* * CDECK ID>, DT_JOIN333 SUBROUTINE DT_JOIN333(IDX1,IDX2,IDX3,IREJ) ************************************************************************ * This subroutine joins a aq-q and a q-aq chain to a third qq-q chain. * * IDX1, IDX2 ,IDX3 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(3,2),IDX(3),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(3,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IDX(3) = IDX3 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX3).NE.IDX3-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX3).NE.IDX3-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTT5=PHKK(1,IDX3-2)**2+PHKK(2,IDX3-2)**2 PPTT6=PHKK(1,IDX3-1)**2+PHKK(2,IDX3-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4,PPTT5,PPTT6) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,3 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join333' C * ,IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2),IDD(3,1),IDD(3,2),'NN', C *IDX1,MO(1,1),MO(1,2),IDX2,MO(2,1),MO(2,2),IDX3,MO(3,1),MO(3,2) * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))+PHKK(K,MO(3,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))+PHKK(K,MO(3,2)) 3 CONTINUE IST1 = ISTHKK(MO(3,1)) IST2 = ISTHKK(MO(3,2)) IF2=IDD(1,2) IDMM1=IDD(3,1)/1000 IDMM2=(IDD(3,1)-IDMM1*1000)/100 IF(IDD(1,1).EQ.-IDMM1)THEN IF(IDD(2,1).GE.IDMM2)IF1=1000*IDD(2,1)+100*IDMM2+3 IF(IDMM2.GT.IDD(2,1))IF1=1000*IDMM2+100*IDD(2,1)+3 ELSEIF(IDD(1,1).EQ.-IDMM2)THEN IF(IDD(2,1).GE.IDMM1)IF1=1000*IDD(2,1)+100*IDMM1+3 IF(IDMM1.GT.IDD(2,1))IF1=1000*IDMM1+100*IDD(2,1)+3 ENDIF C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 IDHKK(IDX(3)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2))+ * VHKK(K,IDX(3)))/3.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2))+ * WHKK(K,IDX(3)))/3.0D0 6 CONTINUE C WRITE(6,*)'Join333 chains IDX1,IDX2,IDX3,NHKK',IDX1,IDX2,IDX3,NHKK RETURN 9999 CONTINUE IREJ = 1 RETURN END * * * *===join34=============================================================* * CDECK ID>, DT_JOIN34 SUBROUTINE DT_JOIN34(IDX1,IDX2,IDX3,IREJ) ************************************************************************ * This subroutine joins a q-aq and a aq-q chain to a third q-aq chain. * * IDX1, IDX2 ,IDX3 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(3,2),IDX(3),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(3,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IDX(3) = IDX3 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX3).NE.IDX3-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX3).NE.IDX3-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTT5=PHKK(1,IDX3-2)**2+PHKK(2,IDX3-2)**2 PPTT6=PHKK(1,IDX3-1)**2+PHKK(2,IDX3-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4,PPTT5,PPTT6) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,3 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join34' C * ,IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2),IDD(3,1),IDD(3,2),'NN', C *IDX1,MO(1,1),MO(1,2),IDX2,MO(2,1),MO(2,2),IDX3,MO(3,1),MO(3,2) * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))+PHKK(K,MO(3,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))+PHKK(K,MO(3,2)) 3 CONTINUE IST1 = ISTHKK(MO(3,1)) IST2 = ISTHKK(MO(3,2)) IF1=IDD(3,1) IF2=IDD(1,2) C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 IDHKK(IDX(3)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2))+ * VHKK(K,IDX(3)))/3.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2))+ * WHKK(K,IDX(3)))/3.0D0 6 CONTINUE C WRITE(6,*)'Join34 chains IDX1,IDX2,IDX3,NHKK ',IDX1,IDX2,IDX3,NHKK RETURN 9999 CONTINUE IREJ = 1 RETURN END * * *===join344============================================================* * CDECK ID>, DT_JOIN344 SUBROUTINE DT_JOIN344(IDX1,IDX2,IDX3,IREJ) ************************************************************************ * This subroutine joins a aq-q and a q-aq chain to a third aq-q chain. * * IDX1, IDX2 ,IDX3 DTEVT1 indices of chains to be joined * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION MO(3,2),IDX(3),PCH(4),PP(4),PT(4),P1(4),P2(4) DIMENSION IDD(3,2) IREJ = 0 IDX(1) = IDX1 IDX(2) = IDX2 IDX(3) = IDX3 IF(JMOHKK(1,IDX1).NE.IDX1-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX1).NE.IDX1-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX2).NE.IDX2-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX2).NE.IDX2-1)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(1,IDX3).NE.IDX3-2)THEN IREJ=1 RETURN ENDIF IF(JMOHKK(2,IDX3).NE.IDX3-1)THEN IREJ=1 RETURN ENDIF PPTT1=PHKK(1,IDX1-2)**2+PHKK(2,IDX1-2)**2 PPTT2=PHKK(1,IDX1-1)**2+PHKK(2,IDX1-1)**2 PPTT3=PHKK(1,IDX2-2)**2+PHKK(2,IDX2-2)**2 PPTT4=PHKK(1,IDX2-1)**2+PHKK(2,IDX2-1)**2 PPTT5=PHKK(1,IDX3-2)**2+PHKK(2,IDX3-2)**2 PPTT6=PHKK(1,IDX3-1)**2+PHKK(2,IDX3-1)**2 PPTTMAX=MAX(PPTT1,PPTT2,PPTT3,PPTT4,PPTT5,PPTT6) C IF(PPTTMAX.GT.2.D0)THEN IF(PPTTMAX.GT.402.D0)THEN IREJ=1 RETURN C ENDIF PPTTPLUS=PPTTMAX-2.D0 PTLIN=(PPTTPLUS/400.D0)**0.5D0 IF(PTLIN.GT.DT_RNDM(VVV))THEN C IREJ=1 C RETURN ENDIF ENDIF DO 1 I=1,3 DO 2 J=1,2 MO(I,J) = JMOHKK(J,IDX(I)) IDD(I,J) = IDHKK(MO(I,J)) 2 CONTINUE 1 CONTINUE C WRITE(6,*)'Join344' C * ,IDD(1,1),IDD(1,2),IDD(2,1),IDD(2,2),IDD(3,1),IDD(3,2),'NN', C *IDX1,MO(1,1),MO(1,2),IDX2,MO(2,1),MO(2,2),IDX3,MO(3,1),MO(3,2) * join chains DO 3 K=1,4 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))+PHKK(K,MO(3,1)) PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))+PHKK(K,MO(3,2)) 3 CONTINUE IST1 = ISTHKK(MO(3,1)) IST2 = ISTHKK(MO(3,2)) IF1=IDD(1,1) IF2=IDD(3,2) C WRITE(6,*)'IF1,IF2 ',IF1,IF2 C RETURN * put partons again on mass shell XM1 = 0.0D0 XM2 = 0.0D0 IF (IMSHL.EQ.1) THEN XM1 = PYMASS(IF1) XM2 = PYMASS(IF2) ENDIF C WRITE(6,*)'effect of mashel' PPPT=PP(1)**2+PP(2)**2 PTPT=PT(1)**2+PT(2)**2 C WRITE(6,*)'PP,PPPT ',PP,PPPT C WRITE(6,*)'PT,PTPT ',PT,PTPT CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) GOTO 9999 P1PT=P1(1)**2+P1(2)**2 P2PT=P2(1)**2+P2(2)**2 DO 4 I=1,4 PP(I) = P1(I) PT(I) = P2(I) 4 CONTINUE C WRITE(6,*)'P1,P1PT ',P1,P1PT C WRITE(6,*)'P2,P2PT ',P2,P2PT IF(P1PT.GE.PPPT+0.4D0)GO TO 9999 IF(P2PT.GE.PTPT+0.4D0)GO TO 9999 * store new partons in DTEVT1 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), & 0,0,0) CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), & 0,0,0) DO 5 K=1,4 PCH(K) = PP(K)+PT(K) 5 CONTINUE ICCHAI(2,9) = ICCHAI(2,9)+1 * store new chain in DTEVT1 KCH = 191 CALL DT_EVTPUT(KCH,66666,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) IDHKK(IDX(1)) = 22222 IDHKK(IDX(2)) = 22222 IDHKK(IDX(3)) = 22222 * special treatment for space-time coordinates DO 6 K=1,4 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2))+ * VHKK(K,IDX(3)))/3.0D0 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2))+ * WHKK(K,IDX(3)))/3.0D0 6 CONTINUE C WRITE(6,*)'Join344 chains IDX1,IDX2,IDX3,NHKK',IDX1,IDX2,IDX3,NHKK RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===jspara=============================================================* * CDECK ID>, DT_JSPARA SUBROUTINE DT_JSPARA(MODE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, & ONE=1.0D0,ZERO=0.0D0) LOGICAL LFIRST INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) C QARU(I) = PARU(I) ENDIF IF (MSTJ(I).NE.ISTJ(I)) THEN IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 * *===kkevnt=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG * Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ * flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF * interface HADRIN-DPM COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA * nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN * coordinates of nucleons COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) * interface between Glauber formalism and DPM COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), & INTER1(MAXINT),INTER2(MAXINT) * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC * central particle production, impact parameter biasing COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR **temporary * statistics: Glauber-formalism COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB ** COMMON / DBGPRE / LDBGPR LOGICAL LDBGPR DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ IREJ = 0 ICREQU = ICREQU+1 NC = 0 1 CONTINUE IF ( LDBGPR ) THEN cdh WRITE (77,'(A,3I6)') WRITE (LOUT,'(A,3I6)') & ' DT_KKEVNT-1:',IREJ,ICREQU,NC cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF ICSAMP = ICSAMP+1 NC = NC+1 IF (MOD(NC,10).EQ.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) NEVHKK 1000 FORMAT(1X,'DT_KKEVNT: event ',I8,' rejected!') GOTO 9999 END IF * initialize DTEVT1/DTEVT2 CALL DT_EVTINI IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_KKEVNT EVTINI:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * 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 END IF 10 CONTINUE **anfe 10.10.2015 * since the Glauber formalism uses cross-section tables from PHOJET, * one needs to tell phojet to switch to the desired combination now CALL PHO_SETPAR(1,IDT_IPDGHA(IJPROJ),0,ZERO) CALL PHO_SETPAR(2,IDT_IPDGHA(IJTARG),0,ZERO) CALL PHO_SETPCOMB * make sure that Glauber-formalism is called each time the interaction * configuration changed IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN IF ( LDBGPR ) THEN WRITE (LOUT,'(A,7I6)') & ' DT_KKEVNT before GLAUBE:',IP,IT,JJPROJ,NN,NP,NT, & KKMAT ENDIF * sample number of nucleon-nucleon coll. according to Glauber-form. CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,6I6)') WRITE (LOUT,'(A,6I6)') & ' DT_KKEVNT GLAUBE:',IP,IT,JJPROJ,NN,NP,NT cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF NWTSAM = NN NWASAM = NP NWBSAM = NT NEVOLD = NEVHKK IPOLD = IP ITOLD = IT JJPOLD = JJPROJ EPROLD = EPROJ END IF * 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 GO TO 10 END IF * 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) GO TO 10 END IF * get initial nucleon-configuration in projectile and target * rest-system (including Fermi-momenta if requested) CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,3I6,(/,10I6))') WRITE (LOUT,'(A,3I6,(/,10I6))') & ' DT_KKEVNT ININUC-1:',IP,IPZ,MODE,(JSSH(IJK),IJK=1,IP) cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF MODE = 2 IF (EPROJ.LE.EHADTH) MODE = 3 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,3I6,(/,10I6))') WRITE (LOUT,'(A,3I6,(/,10I6))') & ' DT_KKEVNT ININUC-2:',IT,ITZ,MODE,(JTSH(IJK),IJK=1,IT) cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 IF (LPRI.GT.4) . 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 IF (LPRI.GT.4) . WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH ENDIF ENDIF ENDIF ENDIF 1001 FORMAT(1X,'DT_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) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_KKEVNT SPLPTN:',NN,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms CALL DT_NUC2CM IF ( LDBGPR ) THEN cdh WRITE (77,'(A,I6)') WRITE (LOUT,'(A,I6)') & ' DT_KKEVNT NUC2CM:',NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF * collect momenta of chain ends and put them into DTEVT1 CALL DT_GETPTN(IP,NN,NCSY,IREJ1) IF ( LDBGPR ) THEN cdh WRITE (77,'(A,3I6)') WRITE (LOUT,'(A,3I6)') & ' DT_KKEVNT GETPTN:',NN,IREJ1,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF 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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 2 in DT_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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 4 in DT_KKEVNT' GOTO 1 ENDIF ELSE IF (LPRI.GT.4) & WRITE(LOUT,1002) MCGENE 1002 FORMAT(1X,'DT_KKEVNT: warning! event-generator',I4, & ' not available - program stopped') STOP ENDIF IF ( LDBGPR ) THEN cdh WRITE (77,'(A,2I6)') WRITE (LOUT,'(A,2I6)') & ' DT_KKEVNT EVENTx:',MCGENE,NHKK cdh CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2) cdh WRITE(77,'(2X,2Z8)')ISEED1,ISEED2 END IF RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===kkinc==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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, & IFUSION,IFLOW * 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 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR DIMENSION WHAT(6) Cf2py intent(out) IREJ IREJ = 0 ILOOP = 0 100 CONTINUE IF (ILOOP.EQ.4) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) NEVHKK 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,'(A,E10.3,2A,E10.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) * anfe 01.10.2015 patch for non-proton target IF ((IT.EQ.1).AND.(ITZ.EQ.1)) THEN IJTARG = 1 ELSE IF ((IT.EQ.1).AND.(ITZ.EQ.0)) THEN IJTARG = 8 ELSE IF ((IT.EQ.1).AND.(ITZ.EQ.-1)) THEN IJTARG = -2 END IF IBTARG = IIBAR(IJTARG) * 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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 1 in DT_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 (LPRI.GT.4 .AND. IOULEV(1).GT.0) & WRITE(LOUT,*) 'rejected 2 in DT_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 C added j.r. 28.5.06 IF(ICENTR.NE.-100) THEN CALL DT_RESNCL(EPN,NLOOP,2) END IF * evaporation / fission / fragmentation * (if intranuclear cascade was sampled only) IF (LFZC.AND.ICENTR.NE.-100) 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 C 12.6.01 J.R. reject p,n with too large energy MISTX=0 * Disabled by AF on 1-Aug-2015: * DO 8936 IHKK=1,NHKK DO 8936 IHKK=1,-NHKK C IF((ISTHKK(IHKK).EQ.1.OR.ISTHKK(IHKK).EQ.-1).AND. C * (IDHKK(IHKK).EQ.2112.OR.IDHKK(IHKK).EQ.2212))THEN IF((ISTHKK(IHKK).EQ.1.OR.ISTHKK(IHKK).EQ.-1).AND. * (IDHKK(IHKK).NE.80000) * )THEN IF(ABS(PHKK(4,IHKK)).GT.(UMO/2.D0)*1.4D0)THEN PMIST=PHKK(4,IHKK) MISTX=1 C WRITE(Iae,*)' PHKK(4,IHKK).GT.(UMO/2.D0)*1.4D0', C * ' rejection ', C * 'PHKK(4,IHKK)=',PMIST,ISTHKK(IHKK),IDHKK(IHKK),UMO/2.D0 ENDIF IF(ABS(PHKK(4,IHKK)).GT.(UMO/2.D0)*1.2D0)THEN PMIST=PHKK(4,IHKK) XXXMIS=(PHKK(4,IHKK)-(UMO/2.D0)*1.2D0)/EPROJ XXXXMI=XXXMIS*5.D0 IF(XXXXMI.GT.DT_RNDM(VV))THEN PMIST=PHKK(4,IHKK) MISTX=1 C WRITE(Iae,*)' PHKK(4,IHKK).GT.(UMO/2.D0)*1.2D0', C * ' rejection ', C * 'PHKK(4,IHKK)=',PMIST,ISTHKK(IHKK),IDHKK(IHKK),UMO/2.D0 ENDIF ENDIF ENDIF 8936 CONTINUE IF(MISTX.EQ.1)THEN C WRITE(Iae,*)' PHKK(4,IHKK).GT.EPROJ*1.1D0', C * ' rejection ', C * 'PHKK(4,IHKK)=',PMIST,EPROJ GO TO 100 ENDIF C 12.6.01 J.R. reject p,n with too large energy * transform finale state into Lab. IFLAG = 2 CALL DT_BEAMPR(WHAT,DUM,IFLAG) IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) C WRITE(LOUT,*)'DT_KKINC RETURN IREJ,NHKK=',IREJ,NHKK IF (IPI0.EQ.1) CALL DT_DECPI0 RETURN 9999 CONTINUE IREJ = 1 C WRITE(LOUT,*)'DT_KKINC 9999 IREJ=',IREJ RETURN END * *===laevt==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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, & IFUSION,IFLOW * 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) IF (LPRI.GT.4) &WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, & THMIN,THMAX,ELMIN 1003 FORMAT(1X,'DT_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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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)') 'DT_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') IF (LPRI.GT.4) & 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 (LPRI.GT.4 .AND. WGHMAX.LT.WGH) & WRITE(LOUT,1000) YY,WGHMAX,WGH 1000 FORMAT(1X,'DT_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 (LPRI.GT.4 .AND. ABS(Q2-Q2TMP).GT.0.01D0) & WRITE(LOUT,1001) Q2,Q2TMP 1001 FORMAT(1X,'DT_LAEVT: inconsistent kinematics (Q2,Q2TMP) ', & 2F10.4) ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) IF (LPRI.GT.4 .AND. ABS(ECMGN-ECMTMP).GT.TINY10) & WRITE(LOUT,1002) ECMGN,ECMTMP 1002 FORMAT(1X,'DT_LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', & 2F10.2) YYTMP = PPG(4)/PPL0(4) IF (LPRI.GT.4 .AND. ABS(YY-YYTMP).GT.0.01D0) & WRITE(LOUT,1005) YY,YYTMP 1005 FORMAT(1X,'DT_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 * convolute with cross section IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) IF (LPRI.GT.4 .AND. STOTX.LT.STOT) & WRITE(LOUT,'(1X,A,/,6E12.3)') & 'DT_LAEVT: warning STOTX, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,*) 'Problems in DT_LEPDCY',ELEMAX,ELEMAT STOP ENDIF C + C Here performs the rejection C - TEST = DT_RNDM(ETOTEX) * ELEMAX C + C final assignment of variables C - IF ( TEST .GT. ELEMAT ) GO TO 100 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) C 999 CONTINUE RETURN END * *===lm2res=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===lmkine=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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, & IFUSION,IFLOW * 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 IF (LPRI.GT.4) &WRITE(LOUT,'(A)') 'DT_LMKINE: kinematical treatment rejected' IREJ = 1 RETURN END * *===lt2lab=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 * *===lt2lab=============================================================* * CDECK ID>, DT_LT2LAO 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 ************************************************************************ * * * 4) Transformations * * * ************************************************************************ * *===ltini==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 c idp = 0 RETURN END * *===ltnuc==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) MODE 1000 FORMAT(1X,'DT_LTNUC: not supported mode (MODE = ',I3,')') EOUT = EIN POUT = PIN ENDIF RETURN END * *===ltrans=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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,*)'DT_LTRANS corrected',AMDIF2,PZI,PEI,PZO,PEO,MODE,ID ENDIF 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 * * * ************************************************************************ * *===mashel=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) . WRITE(LOUT,'(/1X,A,I3)') & 'DT_MASHEL: inconsistent transformation',IDEV IF (LPRI.GT.4) . WRITE(LOUT,'(1X,A)') 'DT_MASHEL: input momenta/masses:' IF (LPRI.GT.4) . WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 IF (LPRI.GT.4) . WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 IF (LPRI.GT.4) . WRITE(LOUT,'(1X,A)') 'DT_MASHEL: output momenta:' IF (LPRI.GT.4) . WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) IF (LPRI.GT.4) . WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) ENDIF RETURN 9999 CONTINUE IREJ = 1 RETURN END C==================================================================== C. Masses C==================================================================== * *===mass_ini===========================================================* * CDECK ID>, DT_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 * *===modb===============================================================* * CDECK ID>, DT_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 5.5.2012 by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 DATA LFIRST /.TRUE./ if (NIDX.eq.-2) then CALL FL_MODB(B,NIDX,Y) return endif 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) C 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) IF (LPRI.GT.4) & WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), & BIMIN,BIMAX,XSFRAC*100.0D0, & XSFRAC*XSPRO(1,1,NTARG) 1000 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 * *===mytran=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===nclpot=============================================================* * CDECK ID>, DT_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. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 EXTERNAL EXMSAZ 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 * A.F. * EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ) * & -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) IF (LPRI.GT.10) . WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' ELSE * A.F. * EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ) * & -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 * A.F. * EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ) * & -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) IF (LPRI.GT.4) & WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AITZ (',AIT,AITZ,')' ELSE * A.F. * EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ) * & -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 IF (LPRI.GT.4) & 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,'DT_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 * *===newhgr=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI LOGICAL LSTART PARAMETER (ZERO = 0.0D0, & TINY = 1.0D-10) DIMENSION XLIMB(*) * histograms PARAMETER (NHIS=10, 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 IF (LPRI.GT.4) & WRITE(LOUT,1003) IHIS,NHIS,IHIS 1003 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1000) IBIN,NDIM,NDIM 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) IBIN,IHIS 1001 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1002) XLIM1,XLIM2 1002 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1004) XLIM1,XLIM2 1004 FORMAT(1X,'DT_NEWHGR: warning! inconsistent log. ', & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') GOTO 9999 ENDIF IF (XLIM2.LE.XLIM1) THEN IF (LPRI.GT.4) & WRITE(LOUT,1005) XLIM1,XLIM2 1005 FORMAT(1X,'DT_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 * *===noname=============================================================* * CDECK ID>, DT_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 * *===nuc2cm=============================================================* * CDECK ID>, DT_NUC2CM SUBROUTINE DT_NUC2CM ************************************************************************ * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * * nucl. cms. (This subroutine replaces NUCMOM.) * * This version dated 15.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * properties of photon/lepton projectiles COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * Glauber formalism: collision properties COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC **temporary * statistics: Glauber-formalism COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB ** ICWP = 0 ICWT = 0 NWTACC = 0 NWAACC = 0 NWBACC = 0 NPOINT(1) = NHKK+1 NEND = NHKK DO 1 I=1,NEND IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 MODE = ISTHKK(I)-9 C IF (IDHKK(I).EQ.22) THEN C* VDM assumption C PEIN = AAM(33) C IDB = 33 C ELSE C PEIN = PHKK(4,I) C IDB = IDBAM(I) C ENDIF C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, C & PX,PY,PZ,PE,IDB,MODE) IF (PHKK(5,I).GT.ZERO) THEN CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), & PX,PY,PZ,PE,IDBAM(I),MODE) ELSE PX = PGAMM(1) PY = PGAMM(2) PZ = PGAMM(3) PE = PGAMM(4) ENDIF IST = ISTHKK(I)-2 ID = IDHKK(I) C* VDM assumption C IF (ID.EQ.22) ID = 113 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 ENDIF 1 CONTINUE NWTACC = MAX(NWAACC,NWBACC) ICDPR = ICDPR+ICWP ICDTA = ICDTA+ICWT **temporary IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN CALL DT_EVTOUT(4) STOP ENDIF RETURN END * *===outhgr=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=10, 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & WRITE(LOUT,1000) & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) 1000 FORMAT(/,1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) 1001 FORMAT(/,1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1002) NEVTS,INORM,FAC 1002 FORMAT(/,1X,'DT_OUTHGR: warning! normalization request not ', & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, & 'FAC = ',E11.4) RETURN ENDIF IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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,E11.4, & ' to',2X,E11.4,',',2X,I3,' bins') ELSEIF (ISWI(I).EQ.2) THEN IF (LPRI.GT.4) & WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) IF (LPRI.GT.4) & WRITE(LOUT,1007) 1007 FORMAT(1X,'user defined bin structure') ELSEIF (ISWI(I).EQ.3) THEN IF (LPRI.GT.4) & 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,E11.4, & ' to',2X,E11.4,',',2X,I3,' bins') ELSEIF (ISWI(I).EQ.4) THEN IF (LPRI.GT.4) & WRITE(LOUT,1004) & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) IF (LPRI.GT.4) & WRITE(LOUT,1007) ELSE IF (LPRI.GT.4) & WRITE(LOUT,1008) ISWI(I) 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) ENDIF IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') & 'DT_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 C * *===pdf0===============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) . 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A,I4,A)') & 'DT_PDF0: IPAR =',IPAR,' not implemented!' STOP ENDIF RETURN END * *=== phnsch ===========================================================* * CDECK ID>, DT_PHNSCH DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) *----------------------------------------------------------------------* * * * Probability for Hadron Nucleon Single CHain interactions: * * * * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * * Infn - Milan * * * * Last change on 04-jan-94 by Alfredo Ferrari * * * * modified by J.R.for use in DTUNUC 6.1.94 * * * * Input variables: * * Kp = hadron projectile index (Part numbering * * scheme) * * Ktarg = target nucleon index (1=proton, 8=neutron) * * Plab = projectile laboratory momentum (GeV/c) * * Output variable: * * Phnsch = probability per single chain (particle * * exchange) interactions * * * *----------------------------------------------------------------------* IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE PARAMETER ( LUNOUT = 6 ) PARAMETER ( LUNERR = 6 ) PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) PARAMETER ( ZERZER = 0.D+00 ) PARAMETER ( ONEONE = 1.D+00 ) PARAMETER ( TWOTWO = 2.D+00 ) PARAMETER ( FIVFIV = 5.D+00 ) PARAMETER ( HLFHLF = 0.5D+00 ) PARAMETER ( NALLWP = 39 ) PARAMETER ( IDMAXP = 210 ) DIMENSION ICHRGE(39),AM(39) * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) DIMENSION KPTOIP(210) * auxiliary common for reggeon exchange (DTUNUC 1.x) COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), & IQTCHR(-6:6),MQUARK(3,39) DIMENSION SGTCOE (5,33), IHLP (NALLWP) DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) * Conversion from part to paprop numbering DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / DATA SGTCO1 / * 1st reaction: gamma p total &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, * 2nd reaction: gamma d total &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, * 3rd reaction: pi+ p total &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , * 4th reaction: pi- p total &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, * 5th reaction: pi+/- d total &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, * 6th reaction: K+ p total &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, * 7th reaction: K+ n total &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, * 8th reaction: K+ d total &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, * 9th reaction: K- p total &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, * 10th reaction: K- n total &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / DATA SGTCO2 / * 11th reaction: K- d total &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, * 12th reaction: p p total &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, * 13th reaction: p n total &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, * 14th reaction: p d total &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, * 15th reaction: pbar p total &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, * 16th reaction: pbar n total &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, * 17th reaction: pbar d total &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, * 18th reaction: Lamda p total &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / DATA SGTCO3 / * 19th reaction: pi+ p elastic &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , * 20th reaction: pi- p elastic &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , * 21st reaction: K+ p elastic &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, * 22nd reaction: K- p elastic &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, * 23rd reaction: p p elastic &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, * 24th reaction: p d elastic &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, * 25th reaction: pbar p elastic &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, * 26th reaction: pbar p elastic bis &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, * 27th reaction: pbar n elastic &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, * 28th reaction: Lamda p elastic &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, * 29th reaction: K- p ela bis &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, * 30th reaction: pi- p cx &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , * 31st reaction: K- p cx &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , * 32nd reaction: K+ n cx &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , * 33rd reaction: pbar p cx &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / * * +-------------------------------------------------------------------* ICHRGE(KTARG)=IICH(KTARG) AM (KTARG)=AAM (KTARG) * | Check for pi0 (d-dbar) IF ( KP .NE. 26 ) THEN IP = KPTOIP (KP) IF(IP.EQ.0)IP=1 ICHRGE(IP)=IICH(KP) AM (IP)=AAM (KP) * | * +-------------------------------------------------------------------* * | ELSE IP = 23 ICHRGE(IP)=0 * | * +-------------------------------------------------------------------* * +-------------------------------------------------------------------* * | No such interactions for baryon-baryon END IF IF ( IIBAR (KP) .GT. 0 ) THEN DT_PHNSCH = ZERZER RETURN * | * +-------------------------------------------------------------------* * | No "annihilation" diagram possible for K+ p/n ELSE IF ( IP .EQ. 15 ) THEN DT_PHNSCH = ZERZER RETURN * | * +-------------------------------------------------------------------* * | No "annihilation" diagram possible for K0 p/n ELSE IF ( IP .EQ. 24 ) THEN DT_PHNSCH = ZERZER RETURN * | * +-------------------------------------------------------------------* * | No "annihilation" diagram possible for Omebar p/n ELSE IF ( IP .GE. 38 ) THEN DT_PHNSCH = ZERZER RETURN * | * +-------------------------------------------------------------------* * +-------------------------------------------------------------------* * | If the momentum is larger than 50 GeV/c, compute the single * | chain probability at 50 GeV/c and extrapolate to the present * | momentum according to 1/sqrt(s) * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) * | x sqrt(s/s(50)) * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] END IF IF ( PLAB .GT. 50.D+00 ) THEN PLA = 50.D+00 AMPSQ = AM (IP)**2 AMTSQ = AM (KTARG)**2 EPROJ = SQRT ( PLAB**2 + AMPSQ ) UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ EPROJ = SQRT ( PLA**2 + AMPSQ ) UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ UMORAT = SQRT ( UMOSQ / UMO50 ) * | * +-------------------------------------------------------------------* * | P < 3 GeV/c ELSE IF ( PLAB .LT. 3.D+00 ) THEN PLA = 3.D+00 AMPSQ = AM (IP)**2 AMTSQ = AM (KTARG)**2 EPROJ = SQRT ( PLAB**2 + AMPSQ ) UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ EPROJ = SQRT ( PLA**2 + AMPSQ ) UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ UMORAT = SQRT ( UMOSQ / UMO50 ) * | * +-------------------------------------------------------------------* * | P < 50 GeV/c ELSE PLA = PLAB UMORAT = ONEONE * | * +-------------------------------------------------------------------* END IF ALGPLA = LOG (PLA) * +-------------------------------------------------------------------* * | Pions: IF ( IHLP (IP) .EQ. 2 ) THEN ACOF = SGTCOE (1,3) BCOF = SGTCOE (2,3) ENNE = SGTCOE (3,3) CCOF = SGTCOE (4,3) DCOF = SGTCOE (5,3) * | Compute the pi+ p total cross section: SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA ACOF = SGTCOE (1,19) BCOF = SGTCOE (2,19) ENNE = SGTCOE (3,19) CCOF = SGTCOE (4,19) DCOF = SGTCOE (5,19) * | Compute the pi+ p elastic cross section: SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the pi+ p inelastic cross section: SPPPIN = SPPPTT - SPPPEL ACOF = SGTCOE (1,4) BCOF = SGTCOE (2,4) ENNE = SGTCOE (3,4) CCOF = SGTCOE (4,4) DCOF = SGTCOE (5,4) * | Compute the pi- p total cross section: SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA ACOF = SGTCOE (1,20) BCOF = SGTCOE (2,20) ENNE = SGTCOE (3,20) CCOF = SGTCOE (4,20) DCOF = SGTCOE (5,20) * | Compute the pi- p elastic cross section: SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the pi- p inelastic cross section: SPMPIN = SPMPTT - SPMPEL SIGDIA = SPMPIN - SPPPIN * | +----------------------------------------------------------------* * | | Charged pions: besides isospin consideration it is supposed * | | that (pi+ n)el is almost equal to (pi- p)el * | | and (pi+ p)el " " " " (pi- n)el * | | and all are almost equal among each others * | | (reasonable above 5 GeV/c) IF ( ICHRGE (IP) .NE. 0 ) THEN KHELP = KTARG / 8 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP ACOF = SGTCOE (1,JREAC) BCOF = SGTCOE (2,JREAC) ENNE = SGTCOE (3,JREAC) CCOF = SGTCOE (4,JREAC) DCOF = SGTCOE (5,JREAC) * | | Compute the total cross section: SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP ACOF = SGTCOE (1,JREAC) BCOF = SGTCOE (2,JREAC) ENNE = SGTCOE (3,JREAC) CCOF = SGTCOE (4,JREAC) DCOF = SGTCOE (5,JREAC) * | | Compute the elastic cross section: SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | | Compute the inelastic cross section: SHNCIN = SHNCTT - SHNCEL * | | Number of diagrams: NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP * | | Now compute the chain end (anti)quark-(anti)diquark IQFSC1 = 1 + IP - 13 IQFSC2 = 0 IQBSC1 = 1 + KHELP IQBSC2 = 1 + IP - 13 * | | * | +----------------------------------------------------------------* * | | pi0: besides isospin consideration it is supposed that the * | | elastic cross section is not very different from * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) ELSE KHELP = KTARG / 8 K2HLP = ( KP - 23 ) / 3 * | | Number of diagrams: * | | For u ubar (k2hlp=0): * NDIAGR = 2 - KHELP * | | For d dbar (k2hlp=1): * NDIAGR = 2 + KHELP - K2HLP NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) * | | Now compute the chain end (anti)quark-(anti)diquark IQFSC1 = 1 + K2HLP IQFSC2 = 0 IQBSC1 = 1 + KHELP IQBSC2 = 2 - K2HLP * | | * | +----------------------------------------------------------------* * | end pi's * +-------------------------------------------------------------------* * | Kaons: END IF ELSE IF ( IHLP (IP) .EQ. 3 ) THEN ACOF = SGTCOE (1,6) BCOF = SGTCOE (2,6) ENNE = SGTCOE (3,6) CCOF = SGTCOE (4,6) DCOF = SGTCOE (5,6) * | Compute the K+ p total cross section: SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA ACOF = SGTCOE (1,21) BCOF = SGTCOE (2,21) ENNE = SGTCOE (3,21) CCOF = SGTCOE (4,21) DCOF = SGTCOE (5,21) * | Compute the K+ p elastic cross section: SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the K+ p inelastic cross section: SKPPIN = SKPPTT - SKPPEL ACOF = SGTCOE (1,9) BCOF = SGTCOE (2,9) ENNE = SGTCOE (3,9) CCOF = SGTCOE (4,9) DCOF = SGTCOE (5,9) * | Compute the K- p total cross section: SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA ACOF = SGTCOE (1,22) BCOF = SGTCOE (2,22) ENNE = SGTCOE (3,22) CCOF = SGTCOE (4,22) DCOF = SGTCOE (5,22) * | Compute the K- p elastic cross section: SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the K- p inelastic cross section: SKMPIN = SKMPTT - SKMPEL SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) * | +----------------------------------------------------------------* * | | Charged Kaons: actually only K- IF ( ICHRGE (IP) .NE. 0 ) THEN KHELP = KTARG / 8 * | | +-------------------------------------------------------------* * | | | Proton target: IF ( KHELP .EQ. 0 ) THEN SHNCIN = SKMPIN * | | | Number of diagrams: NDIAGR = 2 * | | | * | | +-------------------------------------------------------------* * | | | Neutron target: besides isospin consideration it is supposed * | | | that (K- n)el is almost equal to (K- p)el * | | | (reasonable above 5 GeV/c) ELSE ACOF = SGTCOE (1,10) BCOF = SGTCOE (2,10) ENNE = SGTCOE (3,10) CCOF = SGTCOE (4,10) DCOF = SGTCOE (5,10) * | | | Compute the total cross section: SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | | | Compute the elastic cross section: SHNCEL = SKMPEL * | | | Compute the inelastic cross section: SHNCIN = SHNCTT - SHNCEL * | | | Number of diagrams: NDIAGR = 1 * | | | * | | +-------------------------------------------------------------* * | | Now compute the chain end (anti)quark-(anti)diquark END IF IQFSC1 = 3 IQFSC2 = 0 IQBSC1 = 1 + KHELP IQBSC2 = 2 * | | * | +----------------------------------------------------------------* * | | K0's: (actually only K0bar) ELSE KHELP = KTARG / 8 * | | +-------------------------------------------------------------* * | | | Proton target: (K0bar p)in supposed to be given by * | | | (K- p)in - Sig_diagr IF ( KHELP .EQ. 0 ) THEN SHNCIN = SKMPIN - SIGDIA * | | | Number of diagrams: NDIAGR = 1 * | | | * | | +-------------------------------------------------------------* * | | | Neutron target: (K0bar n)in supposed to be given by * | | | (K- n)in + Sig_diagr * | | | besides isospin consideration it is supposed * | | | that (K- n)el is almost equal to (K- p)el * | | | (reasonable above 5 GeV/c) ELSE ACOF = SGTCOE (1,10) BCOF = SGTCOE (2,10) ENNE = SGTCOE (3,10) CCOF = SGTCOE (4,10) DCOF = SGTCOE (5,10) * | | | Compute the total cross section: SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | | | Compute the elastic cross section: SHNCEL = SKMPEL * | | | Compute the inelastic cross section: SHNCIN = SHNCTT - SHNCEL + SIGDIA * | | | Number of diagrams: NDIAGR = 2 * | | | * | | +-------------------------------------------------------------* * | | Now compute the chain end (anti)quark-(anti)diquark END IF IQFSC1 = 3 IQFSC2 = 0 IQBSC1 = 1 IQBSC2 = 1 + KHELP * | | * | +----------------------------------------------------------------* * | end Kaon's * +-------------------------------------------------------------------* * | Antinucleons: END IF ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN * | For momenta between 3 and 5 GeV/c the use of tabulated data * | should be implemented! ACOF = SGTCOE (1,15) BCOF = SGTCOE (2,15) ENNE = SGTCOE (3,15) CCOF = SGTCOE (4,15) DCOF = SGTCOE (5,15) * | Compute the pbar p total cross section: SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA IF ( PLA .LT. FIVFIV ) THEN JREAC = 26 ELSE JREAC = 25 END IF ACOF = SGTCOE (1,JREAC) BCOF = SGTCOE (2,JREAC) ENNE = SGTCOE (3,JREAC) CCOF = SGTCOE (4,JREAC) DCOF = SGTCOE (5,JREAC) * | Compute the pbar p elastic cross section: SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the pbar p inelastic cross section: SAPPIN = SAPPTT - SAPPEL ACOF = SGTCOE (1,12) BCOF = SGTCOE (2,12) ENNE = SGTCOE (3,12) CCOF = SGTCOE (4,12) DCOF = SGTCOE (5,12) * | Compute the p p total cross section: SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA ACOF = SGTCOE (1,23) BCOF = SGTCOE (2,23) ENNE = SGTCOE (3,23) CCOF = SGTCOE (4,23) DCOF = SGTCOE (5,23) * | Compute the p p elastic cross section: SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | Compute the K- p inelastic cross section: SPPINE = SPPTOT - SPPELA SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV KHELP = KTARG / 8 * | +----------------------------------------------------------------* * | | Pbar: IF ( ICHRGE (IP) .NE. 0 ) THEN NDIAGR = 5 - KHELP * | | +-------------------------------------------------------------* * | | | Proton target: IF ( KHELP .EQ. 0 ) THEN * | | | Number of diagrams: SHNCIN = SAPPIN PUUBAR = 0.8D+00 * | | | * | | +-------------------------------------------------------------* * | | | Neutron target: it is supposed that (ap n)el is almost equal * | | | to (ap p)el (reasonable above 5 GeV/c) ELSE ACOF = SGTCOE (1,16) BCOF = SGTCOE (2,16) ENNE = SGTCOE (3,16) CCOF = SGTCOE (4,16) DCOF = SGTCOE (5,16) * | | | Compute the total cross section: SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 & + DCOF * ALGPLA * | | | Compute the elastic cross section: SHNCEL = SAPPEL * | | | Compute the inelastic cross section: SHNCIN = SHNCTT - SHNCEL PUUBAR = HLFHLF * | | | * | | +-------------------------------------------------------------* * | | Now compute the chain end (anti)quark-(anti)diquark * | | there are different possibilities, make a random choiche: END IF IQFSC1 = -1 RNCHEN = DT_RNDM(PUUBAR) IF ( RNCHEN .LT. PUUBAR ) THEN IQFSC2 = -2 ELSE IQFSC2 = -1 END IF IQBSC1 = -IQFSC1 + KHELP IQBSC2 = -IQFSC2 * | | * | +----------------------------------------------------------------* * | | nbar: ELSE NDIAGR = 4 + KHELP * | | +-------------------------------------------------------------* * | | | Proton target: (nbar p)in supposed to be given by * | | | (pbar p)in - Sig_diagr IF ( KHELP .EQ. 0 ) THEN SHNCIN = SAPPIN - SIGDIA PDDBAR = HLFHLF * | | | * | | +-------------------------------------------------------------* * | | | Neutron target: (nbar n)el is supposed to be equal to * | | | (pbar p)el (reasonable above 5 GeV/c) ELSE * | | | Compute the total cross section: SHNCTT = SAPPTT * | | | Compute the elastic cross section: SHNCEL = SAPPEL * | | | Compute the inelastic cross section: SHNCIN = SHNCTT - SHNCEL PDDBAR = 0.8D+00 * | | | * | | +-------------------------------------------------------------* * | | Now compute the chain end (anti)quark-(anti)diquark * | | there are different possibilities, make a random choiche: END IF IQFSC1 = -2 RNCHEN = DT_RNDM(RNCHEN) IF ( RNCHEN .LT. PDDBAR ) THEN IQFSC2 = -1 ELSE IQFSC2 = -2 END IF IQBSC1 = -IQFSC1 + KHELP - 1 IQBSC2 = -IQFSC2 * | | * | +----------------------------------------------------------------* * | * +-------------------------------------------------------------------* * | Others: not yet implemented END IF ELSE SIGDIA = ZERZER SHNCIN = ONEONE NDIAGR = 0 DT_PHNSCH = ZERZER RETURN * | end others * +-------------------------------------------------------------------* END IF DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) & + IQECHR (IQBSC2) IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) & + IQBCHR (IQBSC2) IQECHC = IQECHC / 3 IQBCHC = IQBCHC / 3 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) & + IQSCHR (IQBSC2) IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) & + IQSCHR (MQUARK(3,IP)) * +-------------------------------------------------------------------* * | Consistency check: IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', & DT_PHNSCH,KP,KTARG,PLA,' ****' WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', & DT_PHNSCH,KP,KTARG,PLA,' ****' DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) * | * +-------------------------------------------------------------------* * +-------------------------------------------------------------------* * | Consistency check: END IF IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN WRITE (LUNOUT,*) &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG WRITE (LUNERR,*) &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG * | * +-------------------------------------------------------------------* * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] END IF IF ( UMORAT .GT. ONEPLS ) & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH & - ONEONE ) * UMORAT + ONEONE ) RETURN * ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) DT_SCHQUA = ONEONE JQFSC1 = IQFSC1 JQFSC2 = IQFSC2 JQBSC1 = IQBSC1 JQBSC2 = IQBSC2 RETURN END !End of function Phnsch * *===phoini=============================================================* * CDECK ID>, DT_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: s.r. 21.01.01 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 current beam selection INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL DOUBLE PRECISION SQSGLOBMAX PARAMETER (MPARMAX=40) PARAMETER (MAXMAPPS=40) PARAMETER (IKNOWN=9) DIMENSION IPAVAIL(IKNOWN) DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/ COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS), & MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP 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, MPARMAX), & HWGX(-1:MAX_PRO_2, MPARMAX), & HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), & HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, & MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX), & MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), & MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX), & MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 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) SAVE 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 * switch Reggeon off C IPAMDL(3)= 0 IREJ1= LPRI IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IREJ1) IF (IP.EQ.1) THEN CALL PHO_SETPAR(1,IDT_IPDGHA(IJP),0, ZERO) ELSE CALL PHO_SETPAR(1,2212,0,ZERO) ENDIF IF (IT.EQ.1) THEN CALL PHO_SETPAR(2,IDT_IPDGHA(IJT),0, ZERO) ELSE CALL PHO_SETPAR(2,2212,0,ZERO) ENDIF 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,1002) SCPF,PTF,PT ELSE IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & WRITE(LOUT,1004) ECMINI 1004 FORMAT(' E_cm = ',E10.3) IF (LPRI.GT.4 .AND. 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 IF (LPRI.GT.4) & 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_SETPAR(1,2212,0,ZERO) CALL PHO_SETPAR(2,2212,0,ZERO) c **anfe define new phojet standard pdfs will be CT14 c Call PHO_SETPDF(2212, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(-2212, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(2112, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(-2112, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(3122, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(3122, idum, 2, 1, 0, 0, -1) c Call PHO_SETPDF(3112, idum, 2, 1, 0, 0, -1) c CALL PHO_SETPDF(211, idum, 5, 2, 0, 0, -1) c CALL PHO_SETPDF(-211, idum, 5, 2, 0, 0, -1) c CALL PHO_SETPDF(321, idum, 5, 2, 0, 0, -1) c CALL PHO_SETPDF(-321, idum, 5, 2, 0, 0, -1) CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) C**anfe Initialize a set of typical hadrons in a cascade c CALL PHO_CASCMOD c**anfe or just the protons and the reset on demand CALL PHO_SETPAR(1,2212,0,0.D0) CALL PHO_SETPAR(2,2212,0,0.D0) CALL PHO_SETPCOMB **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 **anfe remove cascade mod, since the PDFs are defined in PHOJET IF ((IOGLB.EQ.100).AND..FALSE.) THEN IF (LPRI.GT.4) & WRITE(LOUT,1006) 1006 FORMAT(/,' DT_PHOINI: additional parton distribution ', & 'functions assiged (ID,IPAR,ISET)',/) NPDF = 0 DO 3 I=1,30 IF (IPARPD(I).NE.0) THEN WRITE(LOUT,*) 'Cascade path overwrites PDF settings.' NPDF = NPDF+1 IF (NPDF.GT.MAXPDF) STOP ' DT_PHOINI: npdf > maxpdf !' IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN IDPDG = IDT_IPDGHA(I) IPAR = IPARPD(I) ISET = ISETPD(I) IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(1X,'DT_PHOINI: PHOJET event-initialization failed!') STOP ENDIF RETURN END * *===phoxs================================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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./ Cf2py intent(out) STOT,SINE,SDIF1,BEL * 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) C current beam selection INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL DOUBLE PRECISION SQSGLOBMAX PARAMETER (MPARMAX=40) PARAMETER (MAXMAPPS=40) PARAMETER (IKNOWN=9) DIMENSION IPAVAIL(IKNOWN) DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/ COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS), & MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP C cross-section common block INTEGER IPFIL,IFAFIL,IFBFIL DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR, & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF, & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO, & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR, & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR, & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4), & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO, & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR, & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL, & IPFIL,IFAFIL,IFBFIL C energy-interpolation table c INTEGER IEETA2 c PARAMETER ( IEETA2 = 20 ) c INTEGER ISIMAX c DOUBLE PRECISION SIGTAB,SIGECM, ECMF c COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX), c & SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX), c & ISIMAX(MPARMAX) c c* IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN IF (LPRI.GT.4) & WRITE(LOUT,*) MCGENE C1000 FORMAT(1X,'DT_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 c IP = 1 c IF(ECM.LE.SIGECM(1,IP,IDXMPAR)) THEN c I1 = 1 c I2 = 1 c ELSEIF (ECM.LT.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN c DO 1 I=2,ISIMAX(IDXMPAR) c IF (ECM.LE.SIGECM(I,IP,IDXMPAR)) GOTO 2 c 1 CONTINUE c 2 CONTINUE c I1 = I-1 c I2 = I c ELSE c IF (LFIRST) THEN c IF (LPRI.GT.4) c & WRITE(LOUT,'(/1X,A,2E12.3)') c & 'DT_PHOXS: warning! energy above initialization limit (', c & ECM,SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR) c LFIRST = .FALSE. c ENDIF c I1 = ISIMAX(IDXMPAR) c I2 = ISIMAX(IDXMPAR) c ENDIF c FAC2 = ZERO c IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(I1,IP,IDXMPAR)) c & /LOG(SIGECM(I2,IP,IDXMPAR)/ c & SIGECM(I1,IP,IDXMPAR)) c FAC1 = ONE-FAC2 c STOT = FAC2*SIGTAB( 1,I2,IP,IDXMPAR) c & +FAC1*SIGTAB( 1,I1,IP,IDXMPAR) c SINE = FAC2*SIGTAB(28,I2,IP,IDXMPAR) c & +FAC1*SIGTAB(28,I1,IP,IDXMPAR) c SDIF1 = FAC2*(SIGTAB(30,I2,IP,IDXMPAR)+ c & SIGTAB(32,I2,IP,IDXMPAR))+ c & FAC1*(SIGTAB(30,I1,IP,IDXMPAR)+ c & SIGTAB(32,I1,IP,IDXMPAR)) c BEL = FAC2*SIGTAB(39,I2,IP,IDXMPAR)+ c & FAC1*SIGTAB(39,I1,IP,IDXMPAR) C let PHOJET know about projectile and target and initialize the index CALL PHO_SETPAR(1,IDT_IPDGHA(KPROJ),0,KPROJ) CALL PHO_SETPAR(2,IDT_IPDGHA(KTARG),0,KTARG) CALL PHO_SETPCOMB C Calculate cross-sections in ordinary PHOJET interpolation routine CALL pho_csint(1, IDT_IPDGHA(KPROJ), IDT_IPDGHA(KTARG), & IDUM, IDUM, ECM, DUM, DUM) C Read out the result STOT = sigtot SINE = sigine C Single diffractive cross-section SDIF1 = siglsd(1) + sighsd(1) + siglsd(2) + sighsd(2) BEL = sloel ENDIF RETURN END * *===poilik=============================================================* * CDECK ID>, DT_POILIK SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) IMPLICIT DOUBLE PRECISION(A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) PARAMETER (NE = 8) INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL DOUBLE PRECISION SQSGLOBMAX PARAMETER (MPARMAX=40) PARAMETER (MAXMAPPS=40) PARAMETER (IKNOWN=9) DIMENSION IPAVAIL(IKNOWN) DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/ COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS), & MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP 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, ECMF COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX), & SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX), & ISIMAX(MPARMAX) ** * VDM parameter for photon-nucleus interactions COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) **sr 22.7.97 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 ** 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(1,IP,IDXMPAR)) THEN I1 = 1 I2 = 1 ELSE IF(ECM.LT.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN DO 50 I=2,ISIMAX(IDXMPAR) IF(ECM.LE.SIGECM(I,IP,IDXMPAR)) GOTO 200 50 CONTINUE 200 CONTINUE I1 = I-1 I2 = I ELSE IF (LPRI.GT.4) & WRITE(LOUT,'(/1X,A,2E12.3)') & 'DT_POILIK: WARNING:TOO HIGH ENERGY',ECM, & SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR) I1 = ISIMAX(IDXMPAR) I2 = ISIMAX(IDXMPAR) ENDIF FAC2 = ZERO IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(I1,IP,IDXMPAR))/ & LOG(SIGECM(I2,IP,IDXMPAR)/ & SIGECM(I1,IP,IDXMPAR)) 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 C SIGTOT = FAC2*SIGTAB(,IP,IDXMPAR 1,I2)+FAC1*SIGTAB(,IP,IDXMPAR 1,I1) CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) IF (ISHAD(1).EQ.1) THEN SIGDIR = FAC2*SIGTAB(29,I2,IP,IDXMPAR)+ & FAC1*SIGTAB(29,I1,IP,IDXMPAR) 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 **sr 22.7.97 IF (MODE.EQ.1) RETURN 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 * *===prepola============================================================* * CDECK ID>, DT_PREPOLA SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) c c By G. Battistoni and E. Scapparone (sept. 1997) c According to: c Albright & Jarlskog, Nucl Phys B84 (1975) 467 c c IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE INTEGER MAXLND, N,NPAD,K DOUBLE PRECISION P,V PARAMETER (MAXLND=12000) COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) SAVE /PYJETS/ 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 RMPI = 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/(RMPI**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(*,*) 'DT_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(*,*) 'DT_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(*,*) 'DT_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 * *===profbi=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI SAVE PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) LOGICAL LSTART CHARACTER CNAME*80 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 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 IF (LPRI.GT.4) . WRITE(LOUT,1000) 1000 FORMAT(1X,'DT_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 IF (LPRI.GT.4) & WRITE(LOUT,1001) NNA,NNB,PPN 1001 FORMAT(1X,'DT_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 * *===qel_pol============================================================* * CDECK ID>, DT_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 * *===qgaus==============================================================* * CDECK ID>, DT_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 * *===raco===============================================================* * CDECK ID>, DT_RACO SUBROUTINE DT_RACO(WX,WY,WZ) ************************************************************************ * Direction cosines of random uniform (isotropic) direction in three * * dimensional space * * Processed by S. Roesler, 20.11.95 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) 10 CONTINUE X = TWO*DT_RNDM(WX)-ONE Y = DT_RNDM(X) X2 = X*X Y2 = Y*Y IF (X2+Y2.GT.ONE) GOTO 10 CFE = (X2-Y2)/(X2+Y2) SFE = TWO*X*Y/(X2+Y2) * z = 1/2 [ 1 + cos (theta) ] Z = DT_RNDM(X) * 1/2 sin (theta) WZ = SQRT(Z*(ONE-Z)) WX = TWO*WZ*CFE WY = TWO*WZ*SFE WZ = TWO*Z-ONE RETURN END * *===rannor=============================================================* * CDECK ID>, DT_RANNOR SUBROUTINE DT_RANNOR(X,Y) ************************************************************************ * Sampling from Gaussian distribution. * * Processed by S. Roesler, 6.5.95 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE PARAMETER (TINY10=1.0D-10) CALL DT_DSFECF(SFE,CFE) V = MAX(TINY10,DT_RNDM(X)) A = SQRT(-2.D0*LOG(V)) X = A*SFE Y = A*CFE RETURN END * *===resncl=============================================================* * CDECK ID>, DT_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. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER ( KALGNM = 2 ) PARAMETER ( KALCH8 = 1 ) PARAMETER ( I2ALGN = 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 ( EXCSSV = +35.23192357547063 D+00 ) PARAMETER ( ENGLGB = -35.23192357547063 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 ( RHFLMN = 1.0D-10 ) REAL ZERSNG PARAMETER ( ZERSNG = 0.E+00 ) 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 ( ELEVEN = 11.D+00 ) PARAMETER ( TWELVE = 12.D+00 ) PARAMETER ( FIFTEN = 15.D+00 ) PARAMETER ( SIXTEN = 16.D+00 ) PARAMETER ( HLFHLF = 0.5D+00 ) PARAMETER ( ONETHI = ONEONE / THRTHR ) PARAMETER ( ONEFOU = ONEONE / FOUFOU ) PARAMETER ( ONEFIV = ONEONE / FIVFIV ) PARAMETER ( ONESIX = ONEONE / SIXSIX ) PARAMETER ( ONESEV = ONEONE / SEVSEV ) PARAMETER ( ONEEIG = ONEONE / EIGEIG ) PARAMETER ( TWOTHI = TWOTWO / THRTHR ) PARAMETER ( THRFOU = THRTHR / FOUFOU ) PARAMETER ( THRTWO = THRTHR / TWOTWO ) PARAMETER ( FOUTHR = FOUFOU / THRTHR ) PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) PARAMETER ( R3TOVL = FOUFOU * PIPIPI / THRTHR ) PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) PARAMETER ( SQRTPI = 1.772453850905516027298167483341D+00 ) PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) PARAMETER ( S2FWHM = 2.354820045030949382023138652919D+00 ) PARAMETER ( TWOLOG = 0.693147180559945309417232121458D+00 ) PARAMETER ( TWO2O3 = 1.587401051968199474751705639272D+00 ) PARAMETER ( TENLOG = 2.302585092994045684017991454684D+00 ) PARAMETER ( ATNFOU = 1.3258176636680326D+00 ) PARAMETER ( ATNSIX = 1.4056476493802699D+00 ) PARAMETER ( CLIGHT = 2.99792458 D+10 ) PARAMETER ( AVOGAD = 6.0221367 D+23 ) PARAMETER ( BOLTZM = 1.380658 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 ( AMPRMU = 1.007276470 D+00 ) PARAMETER ( AMNEMU = 1.008664904 D+00 ) PARAMETER ( EPSIL0 = 8.854187817 D-12 ) 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 ( AMPRTN = 0.93827231 D+00 ) PARAMETER ( AMNTRN = 0.93956563 D+00 ) PARAMETER ( AMDEUT = 1.87561339 D+00 ) PARAMETER ( AMALPH = 3.72738025692891 D+00 ) PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 & * 1.D-09 ) PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) PARAMETER ( ALAMB0 = TWOTWO * PIPIPI * RCLSEL / ALPFSC ) PARAMETER ( BLTZMN = 8.617385 D-14 ) PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) PARAMETER ( GFOHB3 = 1.16639 D-05 ) PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) PARAMETER ( SIN2TW = 0.2319 D+00 ) PARAMETER ( PRMGNM = 2.792847386 D+00 ) PARAMETER ( ANMGNM =-1.91304275 D+00 ) PARAMETER ( REARTH = 6.378140 D+08 ) PARAMETER ( AUASTU = 1.4959787066 D+13 ) PARAMETER ( GEVMEV = 1.0 D+03 ) PARAMETER ( EV2GEV = 1.0 D-09 ) PARAMETER ( GEV2EV = 1.0 D+09 ) PARAMETER ( EMVGEV = 1.0 D-03 ) PARAMETER ( CMQ2MB = 1.0 D+27 ) PARAMETER ( FMB2BA = 1.0 D-03 ) PARAMETER ( BAR2MB = 1.0 D+03 ) PARAMETER ( FMB2FS = 1.0 D-01 ) PARAMETER ( FMS2MB = 1.0 D+01 ) PARAMETER ( BA2CMQ = 1.0 D-24 ) PARAMETER ( CMQ2BA = 1.0 D+24 ) PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) PARAMETER ( GEVOMG = CLIGHT * 1.D+13 / PLABRC ) PARAMETER ( S0THMS = EIGEIG / THRTHR * PIPIPI * RCLSEL * RCLSEL & * CMQ2MB ) PARAMETER ( FERTHO = 14.33 D-09 ) PARAMETER ( EXPEBN = 2.39 D+00 ) PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) PARAMETER ( AMEMEV = GEVMEV * AMELCT ) PARAMETER ( T12INF = 1.D+30 ) PARAMETER ( T12ZER = 1.D-15 ) LOGICAL LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS, LUSRIN, & LUSRGL, LNMGEO, LNMINP, LFRFMT, LDMPCR LOGICAL LFDRTR COMMON / GLOBAL / LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS, LUSRIN, & LUSRGL, LNMGEO, LNMINP, LFRFMT, LDMPCR, & LFDRTR, & KFLGEO, KFLDNR COMMON / GLOBCH / CRVRFL CHARACTER*8 CRVRFL SAVE / GLOBAL /, / GLOBCH / SAVE * COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) PARAMETER (AMUAMU = AMUGEV, & FM2MM = 1.0D-12, & RNUCLE = 1.12D0) PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * 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(MAXNCL), & ITW(MAXNCL) * 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) EXTERNAL EXMSAZ 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_RESNCL: 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) * A.F. * 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) * A.F. * 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) * A.F. * 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) * A.F. * 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 * * Pinipr,Pinita projectile/target 4-momenta in the n-n cms system * RETURN *------- treatment of final state 2 CONTINUE NLOOP = NLOOP+1 IF (NLOOP.GT.1) SCPOT = 0.10D0 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) .EQ. 0) THEN * baryons: keep all nucleons and all others where flag is set ELSE 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 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 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 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 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 .AND. LPRI.GT.4) & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) 2000 FORMAT(1X,'DT_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 .AND. LPRI.GT.4) & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC 2001 FORMAT(1X,'DT_RESNCL: 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 * *===respt==============================================================* * CDECK ID>, DT_RESPT SUBROUTINE DT_RESPT ************************************************************************ * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * * This version dated 18.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * get index of first chain DO 1 I=NPOINT(3),NHKK IF (IDHKK(I).EQ.88888) THEN NC = I GOTO 2 ENDIF 1 CONTINUE 2 CONTINUE IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) * skip VV-,SS- systems IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN * check if both "chains" are resonances IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN CALL DT_SAPTRE(NC,NC+3) ENDIF ENDIF ELSE GOTO 3 ENDIF NC = NC+6 GOTO 2 3 CONTINUE RETURN END * *===rjseac=============================================================* * CDECK ID>, DT_RJSEAC SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) ************************************************************************ * ReJection of SEA-sea Chains. * * MOP1/2 entries of projectile sea-partons in DTEVT1 * * MOT1/2 entries of projectile sea-partons in DTEVT1 * * This version dated 16.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) IREJ = 0 * projectile sea q-aq-pair * indices of sea-pair IDXSEA(1,1) = MOP1 IDXSEA(1,2) = MOP2 * index of mother-nucleon IDXNUC(1) = JMOHKK(1,MOP1) * status of valence quarks to be corrected ISTVAL(1) = -21 * target sea q-aq-pair * indices of sea-pair IDXSEA(2,1) = MOT1 IDXSEA(2,2) = MOT2 * index of mother-nucleon IDXNUC(2) = JMOHKK(1,MOT1) * status of valence quarks to be corrected ISTVAL(2) = -22 DO 1 N=1,2 IDONE = 0 DO 2 I=NPOINT(2),NHKK IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN * valence parton found * inrease 4-momentum by sea 4-momentum DO 3 K=1,4 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ & PHKK(K,IDXSEA(N,2)) 3 CONTINUE PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- & PHKK(2,I)**2-PHKK(3,I)**2)) * "cancel" sea-pair DO 4 J=1,2 ISTHKK(IDXSEA(N,J)) = 100 IDHKK(IDXSEA(N,J)) = 0 JMOHKK(1,IDXSEA(N,J)) = 0 JMOHKK(2,IDXSEA(N,J)) = 0 JDAHKK(1,IDXSEA(N,J)) = 0 JDAHKK(2,IDXSEA(N,J)) = 0 DO 5 K=1,4 PHKK(K,IDXSEA(N,J)) = ZERO VHKK(K,IDXSEA(N,J)) = ZERO WHKK(K,IDXSEA(N,J)) = ZERO 5 CONTINUE PHKK(5,IDXSEA(N,J)) = ZERO 4 CONTINUE IDONE = 1 ENDIF 2 CONTINUE IF (IDONE.NE.1) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 1000 FORMAT(1X,'DT_RJSEAC: event ',I8,': inconsistent event', & '-record!',/,1X,' sea-quark pairs ', & 2I5,4X,2I5,' could not be canceled!') GOTO 9999 ENDIF 1 CONTINUE ICRJSS = ICRJSS+1 RETURN 9999 CONTINUE IREJ = 1 RETURN END * *===RM2================================================================* * CDECK ID>, DT_RM2 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===rnclus=============================================================* * CDECK ID>, DT_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 ************************************************************************ * * * 7) Random number generator package * * * * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * * SERVICE ROUTINES. * * THE ALGORITHM IS FROM * * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * * IMPLEMENTATION BY K. HAHN DEC. 88, * * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * * THE PERIOD IS ABOUT 2**144, * * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * * THE PACKAGE CONTAINS * * FUNCTION DT_RNDM(I) : GENERATOR * * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * *--- * * FUNCTION DT_RNDM(I) * * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * * I - DUMMY VARIABLE, NOT USED * * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * * NA? MUST BE IN 1..178 AND NOT ALL 1 * * 12,34,56 ARE THE STANDARD VALUES * * NB1 MUST BE IN 1..168 * * 78 IS THE STANDARD VALUE * * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * * AS AFTER THE LAST DT_RNDMOU CALL ) * * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * * TAKES SEED FROM GENERATOR * * U(97),C,CD,CM,I,J - SEED VALUES * * SUBROUTINE DT_RNDMTE(IO) * * TEST OF THE GENERATOR * * IO - DEFINES OUTPUT * * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * * = 1 OUTPUT INDEPENDEND ON AN ERROR * * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * * SAME STATUS * * AS BEFORE CALL OF DT_RNDMTE * ************************************************************************ * *===rndm===============================================================* * CDECK ID>, DT_RNDM DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE cdh #### c for linking with corsika we use the corsika random generator DT_RNDM = RNDM(VDUMMY) cdh #### * random number generator * COMMON /DTRAND/ U(97),C,CD,CM,I,J * * counter of calls to random number generator * uncomment if needed C COMMON /DTRNCT/ IRNCT0,IRNCT1 C LOGICAL LFIRST C DATA LFIRST /.TRUE./ * * counter of calls to random number generator * uncomment if needed C IF (LFIRST) THEN C IRNCT0 = 0 C IRNCT1 = 0 C LFIRST = .FALSE. C ENDIF *100 CONTINUE * DT_RNDM = U(I)-U(J) * IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 * U(I) = DT_RNDM * I = I-1 * IF ( I.EQ.0 ) I = 97 * J = J-1 * IF ( J.EQ.0 ) J = 97 * C = C-CD * IF ( C.LT.0.0D0 ) C = C+CM * DT_RNDM = DT_RNDM-C * IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 * * IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100 * * counter of calls to random number generator * uncomment if needed C IRNCT0 = IRNCT0+1 RETURN END C**af FLUKA random number generator replaced by DPMJET generator C DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) * C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C SAVE * C * counter of calls to random number generator C * uncomment if needed C C COMMON /DTRNCT/ IRNCT0,IRNCT1 C C LOGICAL LFIRST C C DATA LFIRST /.TRUE./ * C * counter of calls to random number generator C * uncomment if needed C C IF (LFIRST) THEN C C IRNCT0 = 0 C C IRNCT1 = 0 C C LFIRST = .FALSE. C C ENDIF * C DT_RNDM = FLRNDM(VDUMMY) C * counter of calls to random number generator C * uncomment if needed C C IRNCT1 = IRNCT1+1 * C RETURN C END * *===rndmin=============================================================* * CDECK ID>, DT_RNDMIN SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * random number generator COMMON /DTRAND/ U(97),C,CD,CM,I,J DIMENSION UIN(97) DO 10 KKK = 1,97 10 U(KKK) = UIN(KKK) C = CIN CD = CDIN CM = CMIN I = IIN J = JIN RETURN END * *===rndmou=============================================================* * CDECK ID>, DT_RNDMOU SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * random number generator COMMON /DTRAND/ U(97),C,CD,CM,I,J DIMENSION UOUT(97) DO 10 KKK = 1,97 10 UOUT(KKK) = U(KKK) COUT = C CDOUT = CD CMOUT = CM IOUT = I JOUT = J RETURN END * *===rndmst=============================================================* * CDECK ID>, DT_RNDMST SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * random number generator COMMON /DTRAND/ U(97),C,CD,CM,I,J MA1 = NA1 MA2 = NA2 MA3 = NA3 MB1 = NB1 I = 97 J = 33 DO 20 II2 = 1,97 S = 0 T = 0.5D0 DO 10 II1 = 1,24 MAT = MOD(MOD(MA1*MA2,179)*MA3,179) MA1 = MA2 MA2 = MA3 MA3 = MAT MB1 = MOD(53*MB1+1,169) IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T 10 T = 0.5D0*T 20 U(II2) = S C = 362436.0D0/16777216.0D0 CD = 7654321.0D0/16777216.0D0 CM = 16777213.0D0/16777216.0D0 RETURN END * *===rndmte=============================================================* * CDECK ID>, DT_RNDMTE SUBROUTINE DT_RNDMTE(IO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DIMENSION UU(97),U(6),X(6),D(6) DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, +8354498.D0, 10633180.D0/ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) CALL DT_RNDMST(12,34,56,78) DO 10 II1 = 1,20000 10 XX = DT_RNDM(XX) SD = 0.0D0 DO 20 II2 = 1,6 X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) D(II2) = X(II2)-U(II2) 20 SD = SD+D(II2) CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) **sr 24.01.95 C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN C WRITE(6,1000) C1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', C & ' passed') ENDIF ** RETURN C 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, C &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. C &1,F20.1,F15.3,/), ' === END OF TEST ;', C &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') END * *===RRM2===============================================================* * CDECK ID>, DT_RRM2 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===runtt==============================================================* * CDECK ID>, DT_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 * *===SAM2===============================================================* * CDECK ID>, DT_SAM2 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===sampex=============================================================* * CDECK ID>, DT_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 * *===samplw=============================================================* * CDECK ID>, DT_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 * *===sampxb=============================================================* * CDECK ID>, DT_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 * *===samsdq=============================================================* * CDECK ID>, DT_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 * ss-asas pair IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. & ((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 * ss-asas pair IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. & ((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 * ss-asas pair IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. & ((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 * ss-asas pair IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. & ((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 * *===samsqx=============================================================* * CDECK ID>, DT_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 * *===sigano=============================================================* * CDECK ID>, DT_SANO 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===saptre=============================================================* * CDECK ID>, DT_SAPTRE SUBROUTINE DT_SAPTRE(IDX1,IDX2) ************************************************************************ * p-t sampling for two-resonance systems. ("BAMJET-like" method) * * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * * Adopted from the original SAPTRE written by J. Ranft. * * This version dated 18.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW DIMENSION PA1(4),PA2(4),P1(4),P2(4) DATA B3 /4.0D0/ ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) ESMAX = MIN(ESMAX1,ESMAX2) IF (ESMAX.LE.0.05D0) RETURN HMA = PHKK(5,IDX1) DO 1 K=1,4 PA1(K) = PHKK(K,IDX1) PA2(K) = PHKK(K,IDX2) 1 CONTINUE IF (LEMCCK) THEN CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) ENDIF EXEB = 0.0D0 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) BEXP = HMA*(1.0D0-EXEB)/B3 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 WA = AXEXP/(BEXP+AXEXP) XAB = DT_RNDM(WA) 10 CONTINUE * ES is the transverse kinetic energy IF (XAB.LT.WA)THEN X = DT_RNDM(WA) Y = DT_RNDM(WA) ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) ELSE X = DT_RNDM(Y) ES = ABS(-LOG(X+TINY7)/B3) ENDIF IF (ES.GT.ESMAX) GOTO 10 ES = ES+HMA * transverse momentum HPS = SQRT((ES-HMA)*(ES+HMA)) CALL DT_DSFECF(SFE,CFE) HPX = HPS*CFE HPY = HPS*SFE PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN PA1(1) = PA1(1)+HPX PA1(2) = PA1(2)+HPY PA2(1) = PA2(1)-HPX PA2(2) = PA2(2)-HPY * put resonances on mass-shell again XM1 = PHKK(5,IDX1) XM2 = PHKK(5,IDX2) CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) IF (IREJ1.NE.0) RETURN IF (LEMCCK) THEN CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) IF (IREJ1.NE.0) RETURN ENDIF DO 2 K=1,4 PHKK(K,IDX1) = P1(K) PHKK(K,IDX2) = P2(K) 2 CONTINUE RETURN END * *===scn4ba=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, & TINY10=1.0D-10) PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * event history PARAMETER (NMXHKK=250000) 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(MAXNCL), & ITW(MAXNCL) * 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) 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) 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 * *===scn4cr=============================================================* * CDECK ID>, DT_SCN4CR SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) ************************************************************************ * SCan q-aq chains for Color Ropes. * * This version dated 11.01.95 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) * extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) DIMENSION IDXCH(248),IDXJN(248) DO 1 I=1,NCH IF (IDXCH(I).GT.0) THEN NJOIN = 1 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) IDXJN(NJOIN) = I IF (I.LT.NCH) THEN DO 2 J=I+1,NCH IF (IDXCH(J).GT.0) THEN IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) IF (IDXMO.EQ.IDXMO1) THEN NJOIN = NJOIN+1 IDXJN(NJOIN) = J ENDIF ENDIF 2 CONTINUE ENDIF IF (NJOIN.GE.NCHMIN+2) THEN NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) DO 3 J=1,2*NJ,2 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) IF (IREJ1.NE.0) GOTO 3 IDXCH(IDXJN(J)) = 0 IDXCH(IDXJN(J+1)) = 0 3 CONTINUE ENDIF ENDIF 1 CONTINUE RETURN END * *===shfast=============================================================* * CDECK ID>, DT_SHFAST SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, & ONE=1.0D0,TWO=2.0D0) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 * 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 * *===shmaki=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, & THREE=3.0D0) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 * 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 (LPRI.GT.4 .AND. ICOUT.EQ.1) &WRITE(LOUT,1000) 1000 FORMAT(//,1X,'DT_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) .AND. LPRI.GT.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) & .AND. LPRI.GT.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) & .AND. LPRI.GT.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) & .AND. LPRI.GT.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 IF (LPRI.GT.4) & WRITE(LOUT,1004) NA,NB,NCB 1004 FORMAT(1X,'variable energy run: projectile-id:', & I3,' target A/Z: ',I3,' /',I3,/) IF (LPRI.GT.4) & 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) & .AND. LPRI.GT.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 IF (LPRI.GT.4) & 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 ************************************************************************ * * * DPMJET 3.10: 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 * * * *===shndif===============================================================* * CDECK ID>, DT_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 * *===sigemu=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, & OHALF=0.5D0,ONE=1.0D0) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 IF (MCGENE.NE.4) THEN IF (LPRI.GT.4) & WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) IF (LPRI.GT.4) & WRITE(LOUT,1001) SIGTOT,ERRTOT 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1002) SIGELA,ERRELA 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1003) SIGQEP,ERRQEP 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', & F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1004) SIGQET,ERRQET 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', & F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1005) SIGQE2,ERRQE2 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, & ' +-',F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1006) SIGPRO,ERRPRO 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1007) SIGDEL,ERRDEL 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') IF (LPRI.GT.4) & WRITE(LOUT,1008) SIGDQE,ERRDQE 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') ENDIF 2 CONTINUE 1 CONTINUE RETURN END * *===sigga==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 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 * *===siggat=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 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 * *===siggp==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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) C current beam selection INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL DOUBLE PRECISION SQSGLOBMAX PARAMETER (MPARMAX=40) PARAMETER (MAXMAPPS=40) PARAMETER (IKNOWN=9) DIMENSION IPAVAIL(IKNOWN) DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/ COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS), & MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP 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, ECMF COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX), & SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX), & ISIMAX(MPARMAX) ** 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 IF (LPRI.GT.4) & WRITE(LOUT,*) 'DT_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(1,IP,IDXMPAR)) THEN I1 = 1 I2 = 1 ELSEIF (ECM.LT.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN DO 2 I=2,ISIMAX(IDXMPAR) IF (ECM.LE.SIGECM(I,IP,IDXMPAR)) GOTO 3 2 CONTINUE 3 CONTINUE I1 = I-1 I2 = I ELSE IF (LPRI.GT.4) & WRITE(LOUT,'(/1X,A,2E12.3)') & 'DT_SIGGP: WARNING: TOO HIGH ENERGY',ECM, & SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR) I1 = ISIMAX(IDXMPAR) I2 = ISIMAX(IDXMPAR) ENDIF FAC2 = ZERO IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(I1,IP,IDXMPAR))/ & LOG(SIGECM(I2,IP,IDXMPAR)/ & SIGECM(I1,IP,IDXMPAR)) 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( 1,I2,IP,IDXMPAR)+ & FAC1*SIGTAB( 1,I1,IP,IDXMPAR) SINE = FAC2*SIGTAB(28,I2,IP,IDXMPAR)+ & FAC1*SIGTAB(28,I1,IP,IDXMPAR) SDIR = FAC2*SIGTAB(29,I2,IP,IDXMPAR)+ & FAC1*SIGTAB(29,I1,IP,IDXMPAR) **re: STOT = STOT-SDIR ** SDIR = SDIR/(FSUP1*FSUP2) **re: STOT = STOT+SDIR ** ENDIF RETURN END * *===sigtab=============================================================* * CDECK ID>, DT_SIGTBL 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===sigvel=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,*) 'DT_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 * *===sigvp==============================================================* * CDECK ID>, DT_SIGVP DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) ************************************************************************ * sigma_Vp * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===sihnab===============================================================* * CDECK ID>, DT_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 * *===sort1==============================================================* * CDECK ID>, DT_SORT SUBROUTINE DT_SORT(A,N,I0,I1,MODE) ************************************************************************ * This subroutine sorts entries in A in increasing/decreasing order * * of A(3,i). * * MODE = 1 increasing in A(3,i=1..N) * * = 2 decreasing in A(3,i=1..N) * * This version dated 21.04.95 is revised by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DIMENSION A(3,N) M = I1 10 CONTINUE M = I1-1 IF (M.LE.0) RETURN L = 0 DO 20 I=I0,M J = I+1 IF (MODE.EQ.1) THEN IF (A(3,I).LE.A(3,J)) GOTO 20 ELSE IF (A(3,I).GE.A(3,J)) GOTO 20 ENDIF B = A(3,I) C = A(1,I) D = A(2,I) A(3,I) = A(3,J) A(2,I) = A(2,J) A(1,I) = A(1,J) A(3,J) = B A(1,J) = C A(2,J) = D L = 1 20 CONTINUE IF (L.EQ.1) GOTO 10 RETURN END * *===sort1==============================================================* * CDECK ID>, DT_SORT1 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) ************************************************************************ * This subroutine sorts entries in A in increasing/decreasing order * * of A(i). * * MODE = 1 increasing in A(i=1..N) * * = 2 decreasing in A(i=1..N) * * This version dated 21.04.95 is revised by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DIMENSION A(N),IDX(N) M = I1 10 CONTINUE M = I1-1 IF (M.LE.0) RETURN L = 0 DO 20 I=I0,M J = I+1 IF (MODE.EQ.1) THEN IF (A(I).LE.A(J)) GOTO 20 ELSE IF (A(I).GE.A(J)) GOTO 20 ENDIF B = A(I) A(I) = A(J) A(J) = B IX = IDX(I) IDX(I) = IDX(J) IDX(J) = IX L = 1 20 CONTINUE IF (L.EQ.1) GOTO 10 RETURN END * *===splfla=============================================================* * CDECK ID>, DT_SPLFLA SUBROUTINE DT_SPLFLA(NN,MODE) ************************************************************************ * SamPLing of FLAvors of partons at chain ends. * * This subroutine replaces FLKSAA/FLKSAM. * * NN number of nucleon-nucleon interactions * * MODE = 1 sea-flavors * * = 2 valence-flavors * * Based on the original version written by J. Ranft/H.-J. Moehring. * * This version dated 16.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * flavors of partons (DTUNUC 1.x) COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), & IPSQ(MAXSQU),IPSQ2(MAXSQU), & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), & ITSQ(MAXSQU),ITSQ2(MAXSQU), & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), & KKPROJ(MAXVQU),KKTARG(MAXVQU) * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, & IXPV,IXPS,IXTV,IXTS, & INTVV1(MAXVQU),INTVV2(MAXVQU), & INTSV1(MAXVQU),INTSV2(MAXVQU), & INTVS1(MAXVQU),INTVS2(MAXVQU), & INTSS1(MAXSQU),INTSS2(MAXSQU), & INTDV1(MAXVQU),INTDV2(MAXVQU), & INTVD1(MAXVQU),INTVD2(MAXVQU), & INTDS1(MAXSQU),INTDS2(MAXSQU), & INTSD1(MAXSQU),INTSD2(MAXSQU) * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT IF (MODE.EQ.1) THEN * sea-flavors DO 1 I=1,NN IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) IPSAQ(I) = -IPSQ(I) 1 CONTINUE DO 2 I=1,NN ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) ITSAQ(I)= -ITSQ(I) 2 CONTINUE ELSEIF (MODE.EQ.2) THEN * valence flavors DO 3 I=1,IXPV CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) 3 CONTINUE DO 4 I=1,IXTV CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) 4 CONTINUE ENDIF RETURN END * *===splptn=============================================================* * CDECK ID>, DT_SPLPTN SUBROUTINE DT_SPLPTN(NN) ************************************************************************ * SamPLing of ParToN momenta and flavors. * * This version dated 15.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ * sample flavors of sea-quarks CALL DT_SPLFLA(NN,1) * sample x-values of partons at chain ends ECM = UMO CALL DT_XKSAMP(NN,ECM) * samle flavors CALL DT_SPLFLA(NN,2) RETURN END * *===plot===============================================================* * CDECK ID>, DT_SRPLOT SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) ********************************************************************* * 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) * ********************************************************************* * IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI DIMENSION XX(61),YY(61),LL(101,10) DIMENSION X(N),Y(N),L(40),LOV(40,10) CHARACTER L, LL, LOV DATA L/ & '*','2','3','4','5','6','7','8','9','Z', & '+','A','O','B','C','D','E','F','G','H', & 'I','J','K','L','M','N','O','P','Q','R', & 'S','T','U','V','W','X','Y','1','-',' '/ * * 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , & (LOV(J,I),J=1,10) 80 CONTINUE 90 CONTINUE * * IF (LPRI.GT.4) &WRITE(LOUT, 520) IF (LPRI.GT.4) &WRITE(LOUT, 500) (YY(I),I=1,11) RETURN * 500 FORMAT(11X,11(1PE10.2),'OVERPRINTED') 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) 520 FORMAT(20X,10('1---------'),'1') END * *===statis=============================================================* * CDECK ID>, DT_STATIS SUBROUTINE DT_STATIS(MODE) ************************************************************************ * Initialization and output of run-statistics. * * MODE = 1 initialization * * = 2 output * * This version dated 23.01.94 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (TINY3=1.0D-3) * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) * rejection counter COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, & IREXCI(3),IRDIFF(2),IRINC * central particle production, impact parameter biasing COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR * various options for treatment of partons (DTUNUC 1.x) * (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT * nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN * flags for particle decays COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 * diquark-breaking mechanism COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 DIMENSION PP(4),PT(4) GOTO (1,2) MODE * initialization 1 CONTINUE * initialize statistics counter ICREQU = 0 ICSAMP = 0 ICCPRO = 0 ICDPR = 0 ICDTA = 0 ICRJSS = 0 ICVV2S = 0 DO 10 I=1,9 ICRES(I) = 0 ICCHAI(1,I) = 0 ICCHAI(2,I) = 0 10 CONTINUE * initialize rejection counter IRPT = 0 IRHHA = 0 LOMRES = 0 LOBRES = 0 IRFRAG = 0 IREVT = 0 IRRES(1) = 0 IRRES(2) = 0 IRCHKI(1) = 0 IRCHKI(2) = 0 IRCRON(1) = 0 IRCRON(2) = 0 IRCRON(3) = 0 IRDIFF(1) = 0 IRDIFF(2) = 0 IRINC = 0 DO 11 I=1,5 ICDIFF(I) = 0 11 CONTINUE DO 12 I=1,8 DO 13 J=0,30 ICEVTG(I,J) = 0 13 CONTINUE 12 CONTINUE RETURN * output 2 CONTINUE * statistics counter IF (LPRI.GT.4) &WRITE(LOUT,1000) 1000 FORMAT(/,/,1X,'DT_STATIS:',20X,'statistics of the run',/, & 28X,'---------------------') IF (LPRI.GT.4) &WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) 1001 FORMAT(/,1X,'number of events requested / sampled',13X, & I8,' / ',I8,/,1X,'number of samp. evts per requested ', & 'event',11X,F9.1) IF (ICDIFF(1).NE.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,1009) ICDIFF 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, & 'low mass high mass',/,24X,'single diffraction', & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) ENDIF IF (ICENTR.GT.0) THEN IF (LPRI.GT.4) & WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), & DBLE(ICSAMP)/DBLE(ICCPRO) 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', & ' of sampled Glauber-events per event',9X,F9.1,/, & 2X,'fraction of production cross section',21X,F10.6) ENDIF IF (LPRI.GT.4) &WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), & DBLE(ICDTA)/DBLE(ICSAMP) 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', & ' nucleons after x-sampling',2(4X,F6.2)) IF (MCGENE.EQ.1) THEN IF (LPRI.GT.4) & WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', & ' event',3X,F9.1) IF (ISICHA.EQ.1) THEN IF (LPRI.GT.4) & WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', & 'of single chains per event',13X,F9.1) ENDIF IF (LPRI.GT.4) & WRITE(LOUT,1006) 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, & 23X,'mean number of chains mean number of chains',/, & 23X,'sampled hadronized having mass of a reso.') IF (LPRI.GT.4) & WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) IF (LPRI.GT.4) & WRITE(LOUT,1008) & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), & DBLE(IRHHA)/DBLE(ICREQU), & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, & 1X,'Chain mass corr. for resonances (EVTRES)',2X, & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', & F7.2,/,1X,'Total no. of rej.', & ' in chain-systems treatment (GETCSY)',/,43X, & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, & 1X,'Total no. of rej. in DPM-treatment of one event', & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, & 'IREXCI(3) = ',I5,/) ELSEIF (MCGENE.EQ.2) THEN IF (LPRI.GT.4) & WRITE(LOUT,1010) ELOJET 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', & F4.1,' GeV') IF (LPRI.GT.4) & WRITE(LOUT,1011) 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') IF (LPRI.GT.4) & WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), & (INT(ICCHAI(2,I)/2.0D0),I=1,8), & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), & ((ICEVTG(I,J),I=1,8),J=3,7), & ((ICEVTG(I,J),I=1,8),J=19,21), & (ICEVTG(I,8),I=1,8), & ((ICEVTG(I,J),I=1,8),J=22,24), & (ICEVTG(I,9),I=1,8), & ((ICEVTG(I,J),I=1,8),J=25,28), & ((ICEVTG(I,J),I=1,8),J=10,18) 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, & ' no-dif.',8I8,/, & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, & ' hi-lo ',8I8,/, & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) IF (LPRI.GT.4) & WRITE(LOUT,1013) 1013 FORMAT(/,1X,'2. chain system statistics -', & ' mean numbers per evt:',/,30X,'---------------------', & /,/,16X,'s-s',7X,'d-s',7X,'s-d') IF (LPRI.GT.4) & WRITE(LOUT,1014) & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) IF (LPRI.GT.4) & WRITE(LOUT,1015) 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') IF (LPRI.GT.4) & WRITE(LOUT,1016) & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) ENDIF CALL DT_CHASTA(1) IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) & .OR.(PDBSEA(3).GT.0.0D0)) THEN IF (LPRI.GT.4) & WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) IF (LPRI.GT.4) & WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) IF (LPRI.GT.4) & WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) IF (LPRI.GT.4) & WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) IF (LPRI.GT.4) & WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', & DBRKA(3,1),DBRKA(3,2), & DBRKA(3,3),DBRKA(3,4) IF (LPRI.GT.4) & WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', & DBRKR(3,1),DBRKR(3,2), & DBRKR(3,3),DBRKR(3,4) IF (LPRI.GT.4) & WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', & DBRKA(3,5),DBRKA(3,6), & DBRKA(3,7),DBRKA(3,8) IF (LPRI.GT.4) & WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', & DBRKR(3,5),DBRKR(3,6), & DBRKR(3,7),DBRKR(3,8) ENDIF FAC = 1.0D0 IF (MCGENE.EQ.2) THEN C CALL PHO_PHIST(-2,SIGMAX) CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) ENDIF CALL DT_XTIME RETURN END * *====sttran============================================================* * CDECK ID>, DT_STTRAN SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) ************************************************************************ * 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 ) * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DATA ANGLSQ/1.D-30/ * * * 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 * *===swpfsp=============================================================* * CDECK ID>, DT_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=250000) 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, & IFUSION,IFLOW PARAMETER ( MXXRGN =20000 ) PARAMETER ( MXXMDF = 710 ) PARAMETER ( MXXMDE = 702 ) PARAMETER ( MFSTCK =70000 ) PARAMETER ( MESTCK = 100 ) PARAMETER ( MOSTCK = 2000 ) PARAMETER ( MXPRSN = 100 ) PARAMETER ( MXPDPM = 800 ) PARAMETER ( MXPSCS =60000 ) PARAMETER ( MXFRAG = 20 ) PARAMETER ( MXGLWN = 300 ) PARAMETER ( MXOUTU = 50 ) PARAMETER ( MXKNWC = 13 ) PARAMETER ( MXESHL = 32 ) PARAMETER ( MXGNPR = 60 ) PARAMETER ( KXHEAV = 30 ) PARAMETER ( NALLWP = 64 ) PARAMETER ( NELEMX = 80 ) PARAMETER ( MPDPDX = 33 ) PARAMETER ( MXHTTR = 260 ) PARAMETER ( MXSEAX = 30 ) 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 ( MXNBLN = 55000000 ) PARAMETER ( NBLNMX = MXNBLN ) 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 SAVE / PAREVT / * 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 = 207 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 208 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 209 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 210 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 * *===swppho=============================================================* * CDECK ID>, DT_SWPPHO SUBROUTINE DT_SWPPHO(ILAB) IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) LOGICAL LSTART * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * properties of photon/lepton projectiles COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC C standard particle data interface INTEGER NMXHEP PARAMETER (NMXHEP=8000) 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 (LPRI.GT.4 .AND. MOD(ICOUNT,500).EQ.0) &WRITE(LOUT,*)' DT_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 * *===tdiff==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) &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 * *===testrot============================================================* * CDECK ID>, DT_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 ' DT_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 * *===testxs=============================================================* * CDECK ID>, DT_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 * * *===title==============================================================* * CDECK ID>, DT_TITLE SUBROUTINE DT_TITLE IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI CHARACTER*6 CVERSI CHARACTER*11 CCHANG DATA CVERSI,CCHANG /'2017.1','05 Mar 2017'/ CALL DT_XTIME cdh IF (LPRI.GT.4) WRITE(LOUT,1000) CVERSI,CCHANG 1000 FORMAT(1X,'+-------------------------------------------------', & '----------------------+',/, & 1X,'|',71X,'|',/, & 1X,'|',23X,'DPMJET-III version ',A6,23X,'|',/, & 1X,'|',71X,'|',/, & 1X,'|',22X,'(Last change: ',A11,')',22X,'|',/, & 1X,'|',20X,' by D. Heck (IKP, KIT Karlsruhe)',19X,'|',/, & 1X,'|',71X,'|',/, & 1X,'|',12X,'Authors:',51X,'|',/, & 1X,'|',21X,'Stefan Roesler (CERN)',25X,'|',/, & 1X,'|',21X,'Anatoli Fedynitch (DESY)',25X,'|',/, & 1X,'|',21X,'Ralph Engel (KIT) ',25X,'|',/, & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',17X,'|',/, & 1X,'|',71X,'|',/, & 1X,'|',12X,'https://dpmjetiii.hepforge.org/', & 28X,'|',/, & 1X,'|',71X,'|',/, & 1X,'+-------------------------------------------------', & '----------------------+',/, & 1X,'|',11X,' Contact: anatoli.fedynitch@desy.de ',24X,'|',/, & 1X,'+-------------------------------------------------', & '----------------------+',/) cdh 24.1.2017 RETURN END * *===tsamcs=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 C IF (EKIN.GT.3.5D0) RETURN IF(KPROJ.EQ.8) GOTO 101 IF(KPROJ.EQ.1) GOTO 102 C* INVALID REACTION IF (LPRI.GT.4) &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 C END IF 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 C END IF 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) C END IF C END IF C END IF 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 C 120 CST=1.0D-2*FLTI-1.0D0 END IF 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 C 50 CST=0.4D0*UNIV END IF 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 * *===usrhis=============================================================* * CDECK ID>, DT_USRHIS SUBROUTINE DT_USRHIS(MODE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE *********************************************************************** * COMMON /DTEVT1/ : * NHKK number of entries in common block * NEVHKK number of the event * ISTHKK(i) status code for entry i * IDHKK(i) identifier for the entry * (for particles: identifier according * to the PDG numbering scheme) * JMOHKK(1,i) pointer to the entry of the first mother * of entry i * JMOHKK(2,i) pointer to the entry of the second mother * of entry i * JDAHKK(1,i) pointer to the entry of the first daughter * of entry i * JDAHKK(2,i) pointer to the entry of the second daughter * of entry i * PHKK(1..3,i) 3-momentum * PHKK(4,i) energy * PHKK(5,i) mass *********************************************************************** * event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) *------------------------------------------------------------------ GOTO (1,2,3) MODE *------------------------------------------------------------------ * 1 CONTINUE * * initializations * * Called with MODE=1 once at the beginning of the run. * RETURN * *------------------------------------------------------------------ * 2 CONTINUE * * scoring of the present event * * Called with MODE=2 every time one event has been finished. * * The final state particles from the actual event (number NEVHKK) * can be found in DTEVT1 and identified by their status: * * ISTHKK(i) = 1 final state particle produced in * photon-/hadron-/nucleon-nucleon collisions or * in intranuclear cascade processes * -1 nucleons, deuterons, H-3, He-3, He-4 evaporated * from excited nucleus and * photons produced in nuclear deexcitation processes * 1001 residual nucleus (ground state) * * The types of these particles/nuclei are given in IDHKK as follows * * all final state part. except nuclei : * IDHKK(i)=particle identifier according to PDG numbering scheme * nuclei (evaporation products, and residual nucleus) : * IDHKK(i)=80000, IDRES(i)=mass number, IDXRES(i)=charge number * * The 4-momenta and masses can be found in PHKK (target nucleus rest frame): * PHKK(1..3,i) 3-momentum (p_x,p_y,p_z) * PHKK(4,i) energy * PHKK(5,i) mass * * * * Pick out the final state particles from DTEVT1 in each event for * instance by the following loop (NHKK=number of entries in the present * event) and fill your histograms C DO 20 I=1,NHKK C IF (ABS(ISTHKK(I)).EQ.1) THEN C ELSEIF (ABS(ISTHKK(I)).EQ.1001) THEN C ENDIF C 20 CONTINUE * At any time during the run a list of the actual entries in DTEVT1 and * DTEVT2 can be obtained (output unit 6) by the following statement: C CALL DT_EVTOUT(4) RETURN * *------------------------------------------------------------------ * 3 CONTINUE * * output/statistics/histograms etc. * * Called with MODE=3 once after all events have been sampled. * RETURN END * *===vv2sch=============================================================* * CDECK ID>, DT_VV2SCH SUBROUTINE DT_VV2SCH ************************************************************************ * Change Valence-Valence chain systems to Single CHain systems for * * hadron-nucleus collisions with meson or antibaryon projectile. * * (Reggeon contribution) * * The single chain system is approximately treated as one chain and a * * meson at rest. * * This version dated 18.01.95 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) LOGICAL LSTART * event history PARAMETER (NMXHKK=250000) 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, & IFUSION,IFLOW * statistics COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), & ICEVTG(8,0:30) DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), & PCH2(4) DATA LSTART /.TRUE./ IFSC = 0 IF (LSTART) THEN IF (LPRI.GT.4) & WRITE(LOUT,1000) 1000 FORMAT(/,1X,'DT_VV2SCH: Reggeon contribution to valance-', & 'valence chains treated') LSTART = .FALSE. ENDIF NSTOP = NHKK * get index of first chain DO 1 I=NPOINT(3),NHKK IF (IDHKK(I).EQ.88888) THEN NC = I GOTO 2 ENDIF 1 CONTINUE 2 CONTINUE IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) & .AND.(NC.LT.NSTOP)) THEN * get valence-valence chains IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN * get "mother"-hadron indices MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) KPROJ = IDT_ICIHAD(IDHKK(MO1)) KTARG = IDT_ICIHAD(IDHKK(MO2)) * Lab momentum of projectile hadron CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ & PHKK(3,MO1)**2) SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) IF (DT_RNDM(PTOT).LE.SICHAP) THEN ICVV2S = ICVV2S+1 * single chain requested * get flavors of chain-end partons MO(1) = JMOHKK(1,NC) MO(2) = JMOHKK(2,NC) MO(3) = JMOHKK(1,NC+3) MO(4) = JMOHKK(2,NC+3) DO 3 I=1,4 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) IF(I,2) = 0 IF (ABS(IDHKK(MO(I))).GE.1000) & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) 3 CONTINUE * which one is the q-aq chain? * N1,N1+1 - DTEVT1-entries for q-aq system * N2,N2+1 - DTEVT1-entries for the other chain IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN K1 = 1 K2 = 3 N1 = NC-2 N2 = NC+1 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN K1 = 3 K2 = 1 N1 = NC+1 N2 = NC-2 ELSE GOTO 10 ENDIF DO 4 K=1,4 PP1(K) = PHKK(K,N1) PT1(K) = PHKK(K,N1+1) PP2(K) = PHKK(K,N2) PT2(K) = PHKK(K,N2+1) 4 CONTINUE AMCH1 = PHKK(5,N1+2) AMCH2 = PHKK(5,N2+2) * get meson-identity corresponding to flavors of q-aq chain ITMP = IRESRJ IRESRJ = 0 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, & ZERO,AMCH1N,1,IDUM) IRESRJ = ITMP * change kinematics of chains CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), & AMCH1,AMCH1N,AMCH2,IREJ1) IF (IREJ1.NE.0) GOTO 10 * check second chain for resonance IDCHAI = 2 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) IF (IREJ1.NE.0) GOTO 10 IF (IDR2.NE.0) IDR2 = 100*IDR2 * add partons and chains to DTEVT1 DO 5 K=1,4 PCH1(K) = PP1(K)+PT1(K) PCH2(K) = PP2(K)+PT2(K) 5 CONTINUE CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), & PP1(3),PP1(4),0,0,0) CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), & PT1(2),PT1(3),PT1(4),0,0,0) KCH = ISTHKK(N1+2)+100 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) IDHKK(N1+2) = 22222 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), & PP2(3),PP2(4),0,0,0) CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), & PT2(2),PT2(3),PT2(4),0,0,0) KCH = ISTHKK(N2+2)+100 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) IDHKK(N2+2) = 22222 ENDIF ENDIF ELSE GOTO 11 ENDIF 10 CONTINUE NC = NC+6 GOTO 2 11 CONTINUE RETURN END * *===xglogy=============================================================* * CDECK ID>, DT_XGLOGY 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,'(/1X,A,2E12.3,/)') & 'DT_XGLOGY: ERROR: YMIN,YMAX ',YMIN,YMAX IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') & 'DT_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 IF (LPRI.GT.4) &WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' IF (LPRI.GT.4) &WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) C C*** write range of X C XZOOM1 = (XMAX-XMIN)/DBLE(7) IF (LPRI.GT.4) &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)) IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) IF (LPRI.GT.4) &WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) 120 FORMAT(6X,7(1PE10.3)) C END * *===xgraph=============================================================* * CDECK ID>, DT_XGRAPH 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) & WRITE(LOUT,'(1X,A)') & 'DT_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 IF (LPRI.GT.4) &WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) C C*** write range of X C XZOOM = (XMAX-XMIN)/DBLE(7) IF (LPRI.GT.4) &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) IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) &WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) IF (LPRI.GT.4) &WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) 120 FORMAT(6X,7(1PE10.3)) END * *====phoini============================================================* * CDECK ID>, DT_XHOINI SUBROUTINE DT_XHOINI C SUBROUTINE DT_PHOINI IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI RETURN END * *===diqbrk=============================================================* * CDECK ID>, DT_DIQBRK SUBROUTINE DT_XIQBRK C SUBROUTINE DT_DIQBRK IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE STOP 'diquark-breaking not implemeted !' RETURN END * *===xksamp=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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=250000) 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, & IFUSION,IFLOW * 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) XVCUT,ECM 1000 FORMAT(' DT_XKSAMP: kin. limit for valence-x', & ' thresholds not allowed (',2E10.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 * *===xmhmd==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * sample Pomeron-x from 1/x-distribution (critical Pomeron) IF (KLOOP.GT.20) RETURN XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) * corr. diffr. mass DT_XMHMD = ECM*SQRT(XDIFF) IF (DT_XMHMD.LT.2.5D0) GOTO 1 RETURN END * *===xmlmd==============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * 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 * *===pohisx=============================================================* * CDECK ID>, DT_XOHISX SUBROUTINE DT_XOHISX(I,X) C SUBROUTINE POHISX(I,X) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RETURN END * *===xsglau=============================================================* * CDECK ID>, DT_XSGLAU SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) ************************************************************************ * Total, elastic, quasi-elastic, inelastic cross sections according to * * Glauber's approach. * * NA / NB mass numbers of proj./target nuclei * * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * * IE,IQ indices of energy and virtuality (the latter for gamma * * projectiles only) * * NIDX index of projectile/target nucleus * * This version dated 17.3.98 is written by S. Roesler * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI COMPLEX*16 CZERO,CONE,CTWO CHARACTER*12 CFILE PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, & ONETHI=ONE/THREE,TINY25=1.0D-25) PARAMETER (TWOPI = 6.283185307179586454D+00, & PI = TWOPI/TWO, & GEV2MB = 0.38938D0, & GEV2FM = 0.1972D0, & ALPHEM = ONE/137.0D0, * proton mass & AMP = 0.938D0, & AMP2 = AMP**2, * approx. nucleon radius & RNUCLE = 1.12D0) * particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL PARAMETER ( MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) * Glauber formalism: parameters COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), & BMAX(NCOMPX),BSTEP(NCOMPX), & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), & NSITEB,NSTATB * Glauber formalism: cross sections COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), & BSLOPE,NEBINI,NQBINI * Glauber formalism: flags and parameters for statistics LOGICAL LPROD CHARACTER*8 CGLB COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD * nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN * VDM parameter for photon-nucleus interactions COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) * parameters for hA-diffraction COMMON /DTDIHA/ DIBETA,DIALPH cdh datadir for path to the data sets to be read in by dpmjet/phojet COMMON /DATADIR/ DATADIR CHARACTER*132 DATADIR COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), & OMPP11,OMPP12,OMPP21,OMPP22, & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, & PPTMP1,PPTMP2 COMPLEX*16 C,CA,CI DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), & COOP2(3,MAXNCL),COOT2(3,MAXNCL), & BPROD(KSITEB) PARAMETER (NPOINT=16) DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) LOGICAL LFIRST,LOPEN DATA LFIRST,LOPEN /.TRUE.,.FALSE./ NTARG = ABS(NIDX) * for quasi-elastic neutrino scattering set projectile to proton * it should not have an effect since the whole Glauber-formalism is * not needed for these interactions.. IF (MCGENE.EQ.4) THEN IJPROJ = 1 ELSE IJPROJ = JJPROJ ENDIF IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN I = INDEX(CGLB,' ') IF (I.EQ.0) THEN CFILE = CGLB//'.glb' cdh OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') c modification for use with corsika using path to data file in DATADIR OPEN(LDAT,STATUS='UNKNOWN', & FILE=DATADIR(1:INDEX(DATADIR,' ')-1)//CGLB//'.glb') ELSEIF (I.GT.1) THEN CFILE = CGLB(1:I-1)//'.glb' cdh OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') c modification for use with corsika using path to data file in DATADIR OPEN(LDAT,STATUS='UNKNOWN', & FILE=DATADIR(1:INDEX(DATADIR,' ')-1)//CGLB(1:I-1)//'.glb') ELSE STOP 'XSGLAU 1' ENDIF LOPEN = .TRUE. ENDIF CZERO = DCMPLX(ZERO,ZERO) CONE = DCMPLX(ONE,ZERO) CTWO = DCMPLX(TWO,ZERO) NEBINI = IE NQBINI = IQ * re-define kinematics S = ECMI**2 Q2 = Q2I X = XI * g(Q2=0)-A, h-A, A-A scattering IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN Q2 = 0.0001D0 X = Q2/(S+Q2-AMP2) * g(Q2>0)-A scattering ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN X = Q2/(S+Q2-AMP2) ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN Q2 = (S-AMP2)*X/(ONE-X) ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN S = Q2*(ONE-X)/X+AMP2 ELSE IF (LPRI.GT.4) & WRITE(LOUT,*) 'DT_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.40).OR.((IJPROJ.GE.97).AND.(IJPROJ.LE.103)) & .OR.(IJPROJ.EQ.109).OR.(IJPROJ.EQ.115)).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) IF (LPRI.GT.4) & WRITE(LOUT,*)'DT_XSGLAU: 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 IF (LPRI.GT.4) & WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, & NA,NB,NSTATB,NSITEB 1000 FORMAT(' DT_XSGLAU: inconsistent input data in file ',A12,/, & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, & ' (NA,NB,NSTATB,NSITEB) ',4I10) STOP ENDIF IF (LPRI.GT.4 .AND. LFIRST) & WRITE(LOUT,1001) CFILE 1001 FORMAT(/,' DT_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 * *===xshn===============================================================* * CDECK ID>, DT_XSHN SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) ************************************************************************ * Total and elastic hadron-nucleon cross section. * * Below 5GeV 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 5GeV). * * 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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI Cf2py intent(out) STOT,SELA PARAMETER (ZERO=0.0D0,ONE=1.0D0) INTEGER NPOIN1, NPOIN2, NPOTOT PARAMETER (PLABLO = 0.1D0, PTHRE = 3.D0, PLABHI = 5.0D0) PARAMETER (NPOINT = 63) 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 current beam selection INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL DOUBLE PRECISION SQSGLOBMAX PARAMETER (MPARMAX=40) PARAMETER (MAXMAPPS=40) PARAMETER (IKNOWN=9) DIMENSION IPAVAIL(IKNOWN) DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/ COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS), & MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP C energy-interpolation table INTEGER IEETA2 PARAMETER ( IEETA2 = 20 ) INTEGER ISIMAX DOUBLE PRECISION SIGTAB,SIGECM, ECMF COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX), & SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX), & ISIMAX(MPARMAX) DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) DIMENSION IDXDAT(25,2) * * energy grid 0.1 GeV - 500 GeV 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) * find energy bin where to join PHOJET and tables DO I=1,NPOINT IF (APL(I).LE.APTHRE) THEN NPOIN1 = I ELSE IF (APL(I).LE.APLABH) THEN NPOTOT = I ELSE GOTO 10 END IF NPOIN2 = NPOTOT - NPOIN1 END DO 10 CONTINUE 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).AND. & (ECMS.LE.SIGECM(ISIMAX(IDXMPAR),1,IDXMPAR))) THEN CALL DT_PHOXS(IP,IT,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) ELSE CALL DT_PHOXS(IP,IT,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 IF (LPRI.GT.4) & WRITE(LOUT,1000) IP,IT 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', & 'proj/target',2I4) STOP 'DT_XSHN: cross sections not implemented for proj/target' 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 IF (LPRI.GT.4) & WRITE(LOUT,1001) PLAB,ECMS 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) STOP ENDIF * index of spectrum * map particles including strange baryons to the 10 available * PDG cross-sections. Currently Sigma is mapped onto Lambda. 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 points to the PDG table entry IDXS = IDXDAT(IDXP,IDXT) * compute momentum bin indices IF (IDXS.EQ.0) RETURN IF (PLAB.LT.PLABLO) THEN IDX0 = 1 IDX1 = 1 ELSEIF (PLAB.GE.PLABHI) THEN IDX0 = NPOTOT IDX1 = NPOTOT 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(IP,IT,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) ASTOT = LOG10(PHOSTO) ASELA = LOG10(PHOSTO-PHOSIN) 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(IP,IT,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) PHOSEL = PHOSTO-PHOSIN ASTOT = LOG10(PHOSTO) ASELA = LOG10(PHOSTO-PHOSIN) 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 * *===xstabl=============================================================* * CDECK ID>, DT_XSTABL SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL * 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 * 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 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 IF (LPRI.GT.4) &WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT 1000 FORMAT(/,1X,'DT_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 IF (LPRI.GT.4) & 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) IF (LPRI.GT.4) & WRITE(LOUT,'(8E10.3)') & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 C WRITE(LOUT,'(4E10.3)') C & E,XDEL,XDQE,XDEL+XDQE ELSE IF (LPRI.GT.4) & 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 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) 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 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN c ENDIF 2 CONTINUE 1 CONTINUE RETURN END * *===xtime==============================================================* * CDECK ID>, DT_XTIME SUBROUTINE DT_XTIME IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI CHARACTER DAT*9,TIM*11 DAT = ' ' TIM = ' ' C CALL GETDAT(IYEAR,IMONTH,IDAY) C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) C CALL DATE(DAT) C CALL TIME(TIM) C WRITE(LOUT,1000) DAT,TIM C1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) RETURN END * *===xvalhm=============================================================* * CDECK ID>, DT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===event==============================================================* * CDECK ID>, DT_XVENT 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 * *====eventb============================================================* * CDECK ID>, DT_XVENTB SUBROUTINE DT_XVENTB(NCSY,IREJ) C SUBROUTINE DT_EVENTB(NCSY,IREJ) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI IF (LPRI.GT.4) &WRITE(LOUT,1000) 1000 FORMAT(1X,'DT_XVENTB: PHOJET-package requested but not linked!') STOP END ************************************************************************ * * * 6) Special functions, algorithms and service routines * * * ************************************************************************ * *===ylamb==============================================================* * CDECK ID>, DT_YLAMB DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) ************************************************************************ * * * auxiliary function for three particle decay mode * * (standard LAMBDA**(1/2) function) * * * * Adopted from an original version written by R. Engel. * * This version dated 12.12.94 is written by S. Roesler. * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE YZ = Y-Z XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) DT_YLAMB = SQRT(XLAM) RETURN END * *===zk=================================================================* * CDECK ID>, DT_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 * *===fl_modb============================================================* * CDECK ID>, FL_MODB SUBROUTINE FL_MODB(B,NIDX,y) ************************************************************************ * 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 * ************************************************************************ IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) LOGICAL LEFT,LFIRST COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL 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 * 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 DOUBLE PRECISION info(4),Barr(200) COMMON /toni/ info,Barr DATA LFIRST /.TRUE./ CALL GLAUBR(PPROJ,UMO,IBPROJ,IT,IP,info,Barr) NTARG = ABS(NIDX) RA = info(3) RB = info(4) 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 = 80 ! <--- 10 CONTINUE I1 = (I0+I2)/2 LEFT = ((Barr(I0)-Y) & *(Barr(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.80) I1 = I0-1 ! <--- GOTO 70 50 CONTINUE I1 = I0+1 GOTO 70 60 CONTINUE GOTO 10 70 CONTINUE X0 = DBLE(I0-1)*info(2) X1 = DBLE(I1-1)*info(2) X2 = DBLE(I2-1)*info(2) Y0 = Barr(I0) Y1 = Barr(I1) Y2 = Barr(I2) C 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 bb= b B = B+0.5D0*info(2) IF (B.LT.ZERO) B = X1 IF (B.GT.info(1)) B = info(1) 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) IF (LPRI.GT.4) & WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), & BIMIN,BIMAX,XSFRAC*100.0D0, & XSFRAC*XSPRO(1,1,NTARG) 10000 FORMAT(/,1X,'FL_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 RASH(1) = RA RBSH(NTARG) = RB c write(0,1) B,IP,IT,IJPROJ,info(3),info(4) c 1 format(' -- FL_MODB --',f13.6,' - ',3i5,' - ',4f13.6) RETURN END C *===hkkhkt=============================================================* C SUBROUTINE HKKHKT(I,J) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE * event history PARAMETER (NMXHKK=250000) 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 * *===ib2pdg=============================================================* * CDECK ID>, IDT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 C**anfe took diquark assembling from phojet due to charmed baryons C**warning side effect: PARMDL(135) fraction of spin-1 diq. active IDT_IB2PDG = IHKKQQ(IDA,IDB) c IDT_IB2PDG = IPHO_DIQU(IHKKQ(IDA),IHKKQ(IDB)) ENDIF RETURN END * *===ibamq==============================================================* * CDECK ID>, IDT_IBJQUA 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 = INT((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 * *===icihad=============================================================* * CDECK ID>, IDT_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 * *===iefund=============================================================* * CDECK ID>, IDT_IEFUND INTEGER FUNCTION IDT_IEFUND(PL,IRE) C*****IEFUN CALCULATES A MOMENTUM INDEX IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 ************************************************************************ * * * 2) Handling of parton flavors and particle indices * * * ************************************************************************ * *===ipdg2b=============================================================* * CDECK ID>, IDT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===ipdgha=============================================================* * CDECK ID>, IDT_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 * *===ipdgqu=============================================================* * CDECK ID>, IDT_IQUARK 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 * *===mchad==============================================================* * CDECK ID>, IDT_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 * ************************************************************************ 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 ************************************************************************ * * * 5) Sampling from distributions * * * ************************************************************************ * *===npoiss=============================================================* * CDECK ID>, IDT_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 COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI 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 * *===mgsbs1=============================================================* * 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 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 C********************************************************************** IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 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 IF (LPRI.GT.4) &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 .AND. LPRI.GT.4) & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ IF(IREJ.GE.1)THEN IF(IPCO.GE.3 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 .AND. LPRI.GT.4) & 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 C380 CONTINUE IF(XVTHR.GT.0.66D0*XDIQP)THEN IREJ=1 IF(ISQ.EQ.3)IREJ=3 IF(IPCO.GE.3 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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) & .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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) .AND. LPRI.GT.4) & WRITE(LOUT,*) ' MGSQBS1: ',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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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,*)'MUSQBS1 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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) .AND. LPRI.GT.4) & WRITE(LOUT,*) ' MGSQBS1: ',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) .AND. LPRI.GT.4) & WRITE(LOUT,*) ' MGSQBS1: ',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,*)'MUSQBS1 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 * *===mgsqbs2============================================================* * 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 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 C********************************************************************** IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 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 .AND. LPRI.GT.4) & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' IPCO=0 RETURN ENDIF IF(IPCO.GE.3 .AND. LPRI.GT.4) & 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 .AND. LPRI.GT.4) & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ IF(IREJ.GE.1)THEN IF(IPCO.GE.3 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 .AND. LPRI.GT.4) & 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 C380 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 * *===musqbs1============================================================* * 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 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 IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 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 IF (LPRI.GT.4) .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 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 .AND. LPRI.GT.4) & 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 C380 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 IF (LPRI.GT.4) & 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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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 IF (LPRI.GT.4) &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) IF (LPRI.GT.4) &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,*)' 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 * *===musqbs2============================================================* * 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 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 IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * event history PARAMETER (NMXHKK=250000) 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 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 .AND. LPRI.GT.4) & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ IF(IREJ.GE.1)THEN IF(IPCO.GE.3 .AND. LPRI.GT.4) & 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 IF (LPRI.GT.4) & 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 .AND. LPRI.GT.4) & 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 C380 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 IF (LPRI.GT.4) & 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,*)' MUSQBS2 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,*)' MUSQBS2 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,*)' MUSQBS2 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 * *===pdfset=============================================================* * CDECK ID>, 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 SAVE RETURN END * *===poluhi=============================================================* * **PHOJET105a C SUBROUTINE XOLUHI(I,X) **PHOJET112 CDECK ID>, PHO_LHIST SUBROUTINE PHO_LHIST(I,X) ** IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RETURN END * *===phist==============================================================* * CDECK ID>, PHO_PHIST SUBROUTINE PHO_PHIST(IMODE,WEIGHT) IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) SAVE COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI * emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) 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 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 C IF (MODE.EQ.3) WRITE(LOUT,*) C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) 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 * *===pho_rndm===========================================================* * CDECK ID>, PHO_RNDM DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DOUBLE PRECISION DUMMY cdh PHO_RNDM = DT_RNDM(DUMMY) PHO_RNDM = RNDM(DUMMY) ! use random generator of CORSIKA RETURN END * *===pyr================================================================* * CDECK ID>, PYR DOUBLE PRECISION FUNCTION PYR(IDUMMY) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE DUMMY = DBLE(IDUMMY) cdh PYR = DT_RNDM(DUMMY) PYR = RNDM(DUMMY) ! use random generator of CORSIKA RETURN END * *===structm============================================================* * CDECK ID>, STRUCTM SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RETURN END * *===structp============================================================* * CDECK ID>, STRUCTP SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RETURN END